me
/
guix
Archived
1
0
Fork 0
Code

Merge branch 'master' into core-updates

master
Ludovic Courtès 2013-09-23 00:35:17 +02:00
parent 0c456db45b f59e9eaac8
commit 5608847c6f
72 changed files with 2286 additions and 647 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -76,3 +76,4 @@ stamp-h[0-9]
/nix/scripts/substitute-binary
/doc/images/bootstrap-graph.png
/doc/images/bootstrap-graph.eps
/guix-register

7
Makefile.am
View File

@ -117,6 +117,13 @@ SH_TESTS = \
tests/guix-hash.sh \
tests/guix-package.sh
if BUILD_DAEMON
SH_TESTS += tests/guix-register.sh
endif BUILD_DAEMON
TESTS = $(SCM_TESTS) $(SH_TESTS)
TEST_EXTENSIONS = .scm .sh

3
THANKS
View File

@ -15,6 +15,9 @@ infrastructure help:
Rafael Ferreira <rafael.f.f1@gmail.com>
Christian Grothoff <christian@grothoff.org>
Matthew Lien <bluet@bluet.org>
Yutaka Niibe <gniibe@fsij.org>
Alex Sassmannshausen <alex.sassmannshausen@gmail.com>
Cyrill Schenkel <cyrill.schenkel@gmail.com>
Jason Self <jself@gnu.org>
Alen Skondro <askondro@gmail.com>
Matthias Wachs <wachs@net.in.tum.de>

2
build-aux/check-available-binaries.scm
View File

@ -49,7 +49,7 @@
#f))))
(let ((result (every (compose (warn (cut has-substitutes? store <>))
derivation-path->output-path)
derivation->output-path)
total)))
(when result
(format (current-error-port) "~a packages found substitutable~%"

4
build-aux/hydra/gnu-system.scm
View File

@ -38,6 +38,7 @@
(use-modules (guix store)
(guix packages)
(guix derivations)
((guix utils) #:select (%current-system))
(gnu packages)
(gnu packages base)
@ -58,7 +59,8 @@
(define* (package->alist store package system
#:optional (package-derivation package-derivation))
"Convert PACKAGE to an alist suitable for Hydra."
`((derivation . ,(package-derivation store package system))
`((derivation . ,(derivation-file-name
(package-derivation store package system)))
(description . ,(package-synopsis package))
(long-description . ,(package-description package))
(license . ,(package-license package))

29
build-aux/hydra/guix.scm
View File

@ -40,6 +40,7 @@
(use-modules (guix store)
(guix packages)
(guix utils)
(guix derivations)
(guix build-system gnu)
(gnu packages version-control)
(gnu packages package-management)
@ -56,14 +57,15 @@
(define* (package->alist store package system
#:optional (package-derivation package-derivation))
"Convert PACKAGE to an alist suitable for Hydra."
`((derivation . ,(package-derivation store package system))
`((derivation . ,(derivation-file-name
(package-derivation store package system)))
(description . ,(package-synopsis package))
(long-description . ,(package-description package))
(license . ,(package-license package))
(home-page . ,(package-home-page package))
(maintainers . ("bug-guix@gnu.org"))))
(define (tarball-package checkout)
(define (tarball-package checkout nix-checkout)
"Return a package that does `make distcheck' from CHECKOUT, a directory
containing a Git checkout of Guix."
(let ((dist (dist-package guix checkout)))
@ -72,12 +74,12 @@ containing a Git checkout of Guix."
(arguments (substitute-keyword-arguments (package-arguments dist)
((#:phases p)
`(alist-cons-before
'autoreconf 'patch-bootstrap-script
'autoreconf 'set-nix-submodule
(lambda _
;; Comment out `git' invocations, since Hydra provides
;; us with a checkout that includes sub-modules.
(substitute* "bootstrap"
(("git ") "true git ")))
;; Tell Git to use the Nix checkout that Hydra gave us.
(zero?
(system* "git" "config" "submodule.nix-upstream.url"
,nix-checkout)))
,p))))
(native-inputs `(("git" ,git)
("graphviz" ,graphviz)
@ -96,11 +98,16 @@ containing a Git checkout of Guix."
(_
(list (%current-system)))))
(define checkout
(define guix-checkout
(assq-ref arguments 'guix))
(format (current-error-port) "using checkout ~s~%" checkout)
(let ((directory (assq-ref checkout 'file-name)))
(define nix-checkout
(assq-ref arguments 'nix))
(format (current-error-port) "using checkout ~s (Nix: ~s)~%"
guix-checkout nix-checkout)
(let ((guix (assq-ref guix-checkout 'file-name))
(nix (assq-ref nix-checkout 'file-name)))
`((tarball . ,(cute package->alist store
(tarball-package directory)
(tarball-package guix nix)
(%current-system))))))

18
daemon.am
View File

@ -25,6 +25,8 @@ CLEANFILES += $(BUILT_SOURCES)
noinst_LIBRARIES = libformat.a libutil.a libstore.a
AM_CXXFLAGS = -Wall
libformat_a_SOURCES = \
nix/boost/format/free_funcs.cc \
nix/boost/format/parsing.cc \
@ -119,6 +121,7 @@ libstore_a_CXXFLAGS = \
$(SQLITE3_CFLAGS) $(LIBGCRYPT_CFLAGS)
bin_PROGRAMS = guix-daemon
sbin_PROGRAMS = guix-register
guix_daemon_SOURCES = \
nix/nix-daemon/nix-daemon.cc \
@ -135,6 +138,21 @@ guix_daemon_LDADD = \
guix_daemon_headers = \
nix/nix-daemon/shared.hh
guix_register_SOURCES = \
nix/guix-register/guix-register.cc
guix_register_CPPFLAGS = \
$(libutil_a_CPPFLAGS) \
$(libstore_a_CPPFLAGS) \
-I$(top_srcdir)/nix/libstore
# XXX: Should we start using shared libs?
guix_register_LDADD = \
libstore.a libutil.a libformat.a -lbz2 \
$(SQLITE3_LIBS) $(LIBGCRYPT_LIBS)
libexec_PROGRAMS = nix-setuid-helper
nix_setuid_helper_SOURCES = \
nix/nix-setuid-helper/nix-setuid-helper.cc

80
doc/guix.texi
View File

@ -659,9 +659,9 @@ version: 7.2alpha6
@item --list-installed[=@var{regexp}]
@itemx -I [@var{regexp}]
List currently installed packages in the specified profile. When
@var{regexp} is specified, list only installed packages whose name
matches @var{regexp}.
List the currently installed packages in the specified profile, with the
most recently installed packages shown last. When @var{regexp} is
specified, list only installed packages whose name matches @var{regexp}.
For each installed package, print the following items, separated by
tabs: the package name, its version string, the part of the package that
@ -679,6 +679,41 @@ For each package, print the following items separated by tabs: its name,
its version string, the parts of the package (@pxref{Packages with
Multiple Outputs}), and the source location of its definition.
@item --list-generations[=@var{pattern}]
@itemx -l [@var{pattern}]
Return a list of generations along with their creation dates; for each
generation, show the installed packages, with the most recently
installed packages shown last.
For each installed package, print the following items, separated by
tabs: the name of a package, its version string, the part of the package
that is installed (@pxref{Packages with Multiple Outputs}), and the
location of this package in the store.
When @var{pattern} is used, the command returns only matching
generations. Valid patterns include:
@itemize
@item @emph{Integers and comma-separated integers}. Both patterns denote
generation numbers. For instance, @code{--list-generations=1} returns
the first one.
And @code{--list-generations=1,8,2} outputs three generations in the
specified order. Neither spaces nor trailing commas are allowed.
@item @emph{Ranges}. @code{--list-generations=2..9} prints the
specified generations and everything in between. Note that the start of
a range must be lesser than its end.
It is also possible to omit the endpoint. For example,
@code{--list-generations=2..}, returns all generations starting from the
second one.
@item @emph{Durations}. You can also get the last @emph{N}@tie{}days, weeks,
or months by passing an integer along with the first letter of the
duration, e.g., @code{--list-generations=20d}.
@end itemize
@end table
@node Packages with Multiple Outputs
@ -987,8 +1022,8 @@ The build actions it prescribes may then be realized by using the
@code{build-derivations} procedure (@pxref{The Store}).
@deffn {Scheme Procedure} package-derivation @var{store} @var{package} [@var{system}]
Return the derivation path and corresponding @code{<derivation>} object
of @var{package} for @var{system} (@pxref{Derivations}).
Return the @code{<derivation>} object of @var{package} for @var{system}
(@pxref{Derivations}).
@var{package} must be a valid @code{<package>} object, and @var{system}
must be a string denoting the target system type---e.g.,
@ -1004,8 +1039,8 @@ package for some other system:
@deffn {Scheme Procedure} package-cross-derivation @var{store} @
@var{package} @var{target} [@var{system}]
Return the derivation path and corresponding @code{<derivation>} object
of @var{package} cross-built from @var{system} to @var{target}.
Return the @code{<derivation>} object of @var{package} cross-built from
@var{system} to @var{target}.
@var{target} must be a valid GNU triplet denoting the target hardware
and operating system, such as @code{"mips64el-linux-gnu"}
@ -1061,15 +1096,16 @@ argument.
Return @code{#t} when @var{path} is a valid store path.
@end deffn
@deffn {Scheme Procedure} add-text-to-store @var{server} @var{name} @var{text} @var{references}
@deffn {Scheme Procedure} add-text-to-store @var{server} @var{name} @var{text} [@var{references}]
Add @var{text} under file @var{name} in the store, and return its store
path. @var{references} is the list of store paths referred to by the
resulting store path.
@end deffn
@deffn {Scheme Procedure} build-derivations @var{server} @var{derivations}
Build @var{derivations} (a list of derivation paths), and return when
the worker is done building them. Return @code{#t} on success.
Build @var{derivations} (a list of @code{<derivation>} objects or
derivation paths), and return when the worker is done building them.
Return @code{#t} on success.
@end deffn
@c FIXME
@ -1119,8 +1155,8 @@ otherwise manipulate derivations. The lowest-level primitive to create
a derivation is the @code{derivation} procedure:
@deffn {Scheme Procedure} derivation @var{store} @var{name} @var{builder} @var{args} [#:outputs '("out")] [#:hash #f] [#:hash-algo #f] [#:hash-mode #f] [#:inputs '()] [#:env-vars '()] [#:system (%current-system)] [#:references-graphs #f]
Build a derivation with the given arguments. Return the resulting store
path and @code{<derivation>} object.
Build a derivation with the given arguments, and return the resulting
@code{<derivation>} object.
When @var{hash}, @var{hash-algo}, and @var{hash-mode} are given, a
@dfn{fixed-output derivation} is created---i.e., one whose result is
@ -1142,16 +1178,13 @@ to a Bash executable in the store:
(guix store)
(guix derivations))
(call-with-values
(lambda ()
(let ((builder ; add the Bash script to the store
(add-text-to-store store "my-builder.sh"
"echo hello world > $out\n" '())))
(derivation store "foo"
bash `("-e" ,builder)
#:env-vars '(("HOME" . "/homeless")))))
list)
@result{} ("/nix/store/@dots{}-foo.drv" #<<derivation> @dots{}>)
(let ((builder ; add the Bash script to the store
(add-text-to-store store "my-builder.sh"
"echo hello world > $out\n" '())))
(derivation store "foo"
bash `("-e" ,builder)
#:env-vars '(("HOME" . "/homeless"))))
@result{} #<derivation /nix/store/@dots{}-foo.drv => /nix/store/@dots{}-foo>
@end lisp
As can be guessed, this primitive is cumbersome to use directly. An
@ -1196,8 +1229,7 @@ containing one file:
(build-expression->derivation store "goo" (%current-system)
builder '()))
@result{} "/nix/store/@dots{}-goo.drv"
@result{} #<<derivation> @dots{}>
@result{} #<derivation /nix/store/@dots{}-goo.drv => @dots{}>
@end lisp
@cindex strata of code

12
gnu-system.am
View File

@ -69,6 +69,7 @@ GNU_SYSTEM_MODULES = \
gnu/packages/gkrellm.scm \
gnu/packages/glib.scm \
gnu/packages/global.scm \
gnu/packages/gnome.scm \
gnu/packages/gnunet.scm \
gnu/packages/gnupg.scm \
gnu/packages/gnutls.scm \
@ -79,6 +80,7 @@ GNU_SYSTEM_MODULES = \
gnu/packages/grub.scm \
gnu/packages/grue-hunter.scm \
gnu/packages/gsasl.scm \
gnu/packages/gstreamer.scm \
gnu/packages/gtk.scm \
gnu/packages/guile.scm \
gnu/packages/gv.scm \
@ -113,7 +115,7 @@ GNU_SYSTEM_MODULES = \
gnu/packages/lua.scm \
gnu/packages/lvm.scm \
gnu/packages/m4.scm \
gnu/packages/mailutils.scm \
gnu/packages/mail.scm \
gnu/packages/make-bootstrap.scm \
gnu/packages/maths.scm \
gnu/packages/mit-krb5.scm \
@ -179,17 +181,24 @@ GNU_SYSTEM_MODULES = \
gnu/packages/yasm.scm \
gnu/packages/zile.scm \
gnu/packages/zip.scm \
\
gnu/system/dmd.scm \
gnu/system/grub.scm \
gnu/system/linux.scm \
gnu/system/shadow.scm \
gnu/system/vm.scm
patchdir = $(guilemoduledir)/gnu/packages/patches
dist_patch_DATA = \
gnu/packages/patches/apr-skip-getservbyname-test.patch \
gnu/packages/patches/automake-skip-amhello-tests.patch \
gnu/packages/patches/avahi-localstatedir.patch \
gnu/packages/patches/bigloo-gc-shebangs.patch \
gnu/packages/patches/binutils-ld-new-dtags.patch \
gnu/packages/patches/cdparanoia-fpic.patch \
gnu/packages/patches/cmake-fix-tests.patch \
gnu/packages/patches/cpio-gets-undeclared.patch \
gnu/packages/patches/dbus-localstatedir.patch \
gnu/packages/patches/diffutils-gets-undeclared.patch \
gnu/packages/patches/emacs-configure-sh.patch \
gnu/packages/patches/findutils-absolute-paths.patch \
@ -203,7 +212,6 @@ dist_patch_DATA = \
gnu/packages/patches/glibc-bootstrap-system.patch \
gnu/packages/patches/glibc-ldd-x86_64.patch \
gnu/packages/patches/glibc-no-ld-so-cache.patch \
gnu/packages/patches/gnutls-fix-tests-on-32-bits-system.patch \
gnu/packages/patches/grub-gets-undeclared.patch \
gnu/packages/patches/guile-1.8-cpp-4.5.patch \
gnu/packages/patches/guile-default-utf8.patch \

10
gnu/packages/avahi.scm
View File

@ -21,6 +21,7 @@
#:use-module (guix packages)
#:use-module (guix download)
#:use-module (guix build-system gnu)
#:use-module (gnu packages)
#:use-module (gnu packages gdbm)
#:use-module (gnu packages libdaemon)
#:use-module (gnu packages pkg-config)
@ -42,13 +43,15 @@
(build-system gnu-build-system)
(arguments
'(#:configure-flags '("--with-distro=none"
"--localstatedir=/var" ; for the DBus socket
"--disable-python"
"--disable-mono"
"--disable-doxygen-doc"
"--disable-xmltoman"
"--enable-tests"
"--disable-qt3" "--disable-qt4"
"--disable-gtk" "--disable-gtk3")))
"--disable-gtk" "--disable-gtk3")
#:patches (list (assoc-ref %build-inputs "patch/localstatedir"))))
(inputs
`(("expat" ,expat)
("glib" ,glib)
@ -56,7 +59,10 @@
("libdaemon" ,libdaemon)
("intltool" ,intltool)
("pkg-config" ,pkg-config)
("gdbm" ,gdbm)))
("gdbm" ,gdbm)
("patch/localstatedir"
,(search-patch "avahi-localstatedir.patch"))))
(synopsis "Avahi, an mDNS/DNS-SD implementation")
(description
"Avahi is a system which facilitates service discovery on a local

2
gnu/packages/cryptsetup.scm
View File

@ -45,7 +45,7 @@
`(("libgcrypt" ,libgcrypt)
("lvm2" ,lvm2)
("popt" ,popt)
("python" ,python)
("python" ,python-wrapper)
("util-linux" ,util-linux)))
(synopsis "hard disk encryption tool")
(description

2
gnu/packages/gdb.scm
View File

@ -53,7 +53,7 @@
("gmp" ,gmp)
("readline" ,readline)
("ncurses" ,ncurses)
("python" ,python)
("python" ,python-wrapper)
("texinfo" ,texinfo)
("dejagnu" ,dejagnu)))
(home-page "http://www.gnu.org/software/gdb/")

2
gnu/packages/ghostscript.scm
View File

@ -136,7 +136,7 @@ printing, and psresize, for adjusting page sizes.")
("libtiff" ,libtiff)
("perl" ,perl)
("pkg-config" ,pkg-config) ; needed to find libtiff
("python" ,python)
("python" ,python-wrapper)
("tcl" ,tcl)
("zlib" ,zlib)))
(arguments

42
gnu/packages/glib.scm
View File

@ -35,9 +35,18 @@
#:use-module (gnu packages python)
#:use-module (gnu packages xml)
#:use-module (gnu packages bash)
#:use-module (gnu packages file))
#:use-module (gnu packages file)
#:use-module (gnu packages xorg)
(define-public dbus
;; Export variables up-front to allow circular dependency with the 'xorg'
;; module.
#:export (dbus
glib
dbus-glib
intltool
itstool))
(define dbus
(package
(name "dbus")
(version "1.6.4")
@ -50,9 +59,26 @@
(base32
"1wacqyfkcpayg7f8rvx9awqg275n5pksxq5q7y21lxjx85x6pfjz"))))
(build-system gnu-build-system)
(arguments
'(#:configure-flags (list ;; Install the system bus socket under /var.
"--localstatedir=/var"
;; XXX: Fix the following to allow system-wide
;; config.
;; "--sysconfdir=/etc"
"--with-session-socket-dir=/tmp")
#:patches (list (assoc-ref %build-inputs "patch/localstatedir"))))
(inputs
`(("expat" ,expat)
("pkg-config" ,pkg-config)))
("pkg-config" ,pkg-config)
("patch/localstatedir"
,(search-patch "dbus-localstatedir.patch"))
;; Add a dependency on libx11 so that 'dbus-launch' has support for
;; '--autolaunch'.
("libx11" ,libx11)))
(home-page "http://dbus.freedesktop.org/")
(synopsis "Message bus for inter-process communication (IPC)")
(description
@ -73,7 +99,7 @@ or through unencrypted TCP/IP suitable for use behind a firewall with
shared NFS home directories.")
(license license:gpl2+))) ; or Academic Free License 2.1
(define-public glib
(define glib
(package
(name "glib")
(version "2.37.1")
@ -92,7 +118,7 @@ shared NFS home directories.")
("gettext" ,guix:gettext)
("libffi" ,libffi)
("pkg-config" ,pkg-config)
("python" ,python)
("python" ,python-wrapper)
("zlib" ,zlib)
("perl" ,perl) ; needed by GIO tests
("dbus" ,dbus) ; for GDBus tests
@ -145,7 +171,7 @@ dynamic loading, and an object system.")
(home-page "http://developer.gnome.org/glib/")
(license license:lgpl2.0+))) ; some files are under lgpl2.1+
(define-public intltool
(define intltool
(package
(name "intltool")
(version "0.50.2")
@ -186,7 +212,7 @@ The intltool collection can be used to do these things:
oaf files. This merge step will happen at build resp. installation time.")
(license license:gpl2+)))
(define-public itstool
(define itstool
(package
(name "itstool")
(version "1.2.0")
@ -220,7 +246,7 @@ information in their documents, such as whether a particular element should be
translated.")
(license license:gpl3+)))
(define-public dbus-glib
(define dbus-glib
(package
(name "dbus-glib")
(version "0.100.2")

57
gnu/packages/gnome.scm 100644
View File

@ -0,0 +1,57 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU 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.
;;;
;;; GNU 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 GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu packages gnome)
#:use-module ((guix licenses) #:select (gpl2+))
#:use-module (guix packages)
#:use-module (guix download)
#:use-module (guix build-system gnu)
#:use-module (gnu packages glib)
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages python)
#:use-module (gnu packages xml))
(define-public gnome-doc-utils
(package
(name "gnome-doc-utils")
(version "0.20.10")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://gnome/sources/" name "/0.20/"
name "-" version ".tar.xz"))
(sha256
(base32
"19n4x25ndzngaciiyd8dd6s2mf9gv6nv3wv27ggns2smm7zkj1nb"))))
(build-system gnu-build-system)
(inputs
`(("intltool" ,intltool)
("libxml2" ,libxml2)
("libxslt" ,libxslt)
("pkg-config" ,pkg-config)
("python-2" ,python-2)))
(arguments
`(#:tests? #f)) ; tries to load http://www.oasis-open.org/docbook/xml/4.4/docbookx.dtd
(home-page "https://wiki.gnome.org/GnomeDocUtils")
(synopsis
"Documentation utilities for the Gnome project")
(description
"Gnome-doc-utils is a collection of documentation utilities for the
Gnome project. It includes xml2po tool which makes it easier to translate
and keep up to date translations of documentation.")
(license gpl2+))) ; xslt under lgpl

2
gnu/packages/gnupg.scm
View File

@ -191,7 +191,7 @@ S/MIME.")
"1g1jly3wl4ks6h8ydkygyl2c4i7v3z91rg42005m6vm70y1d8b3d"))))
(build-system gnu-build-system)
(inputs `(("perl" ,perl)
("python" ,python)
("python" ,python-wrapper)
("gpg" ,gnupg)))
(arguments
`(#:tests? #f

12
gnu/packages/gnutls.scm
View File

@ -54,7 +54,7 @@ portable, and only require an ANSI C89 platform.")
(define-public gnutls
(package
(name "gnutls")
(version "3.2.1")
(version "3.2.4")
(source (origin
(method url-fetch)
(uri
@ -64,20 +64,14 @@ portable, and only require an ANSI C89 platform.")
version ".tar.xz"))
(sha256
(base32
"1zi2kq3vcbqdy9khl7r6pgk4hgwibniasm9k6siasdvqjijq3ymb"))))
"0zvhzy87v9dfxfvmg1pl951kw55rp647cqdza8942fxq7spp158i"))))
(build-system gnu-build-system)
(arguments
`(#:patches (list (assoc-ref %build-inputs
"patch/fix-tests"))
#:patch-flags '("-p0")))
(native-inputs
`(("pkg-config" ,pkg-config)))
(inputs
`(("guile" ,guile-2.0)
("zlib" ,guix:zlib)
("perl" ,perl)
("patch/fix-tests"
,(search-patch "gnutls-fix-tests-on-32-bits-system.patch"))))
("perl" ,perl)))
(propagated-inputs
`(("libtasn1" ,libtasn1)
("nettle" ,nettle)

62
gnu/packages/grub.scm
View File

@ -19,9 +19,6 @@
(define-module (gnu packages grub)
#:use-module (guix download)
#:use-module (guix packages)
#:use-module (guix records)
#:use-module (guix store)
#:use-module (guix derivations)
#:use-module ((guix licenses) #:select (gpl3+))
#:use-module (guix build-system gnu)
#:use-module (gnu packages)
@ -33,11 +30,7 @@
#:use-module (gnu packages qemu)
#:use-module (gnu packages ncurses)
#:use-module (gnu packages cdrom)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
#:export (menu-entry
menu-entry?
grub-configuration-file))
#:use-module (srfi srfi-1))
(define qemu-for-tests
;; Newer QEMU versions, such as 1.5.1, no longer support the 'shutdown'
@ -117,56 +110,3 @@ computer starts. It is responsible for loading and transferring control to
the operating system kernel software (such as the Hurd or the Linux). The
kernel, in turn, initializes the rest of the operating system (e.g., GNU).")
(license gpl3+)))
;;;
;;; Configuration.
;;;
(define-record-type* <menu-entry>
menu-entry make-menu-entry
menu-entry?
(label menu-entry-label)
(linux menu-entry-linux)
(linux-arguments menu-entry-linux-arguments
(default '()))
(initrd menu-entry-initrd))
(define* (grub-configuration-file store entries
#:key (default-entry 1) (timeout 5)
(system (%current-system)))
"Return the GRUB configuration file in STORE for ENTRIES, a list of
<menu-entry> objects, defaulting to DEFAULT-ENTRY and with the given TIMEOUT."
(define prologue
(format #f "
set default=~a
set timeout=~a
search.file ~a~%"
default-entry timeout
(any (match-lambda
(($ <menu-entry> _ linux)
(let* ((drv (package-derivation store linux system))
(out (derivation-path->output-path drv)))
(string-append out "/bzImage"))))
entries)))
(define entry->text
(match-lambda
(($ <menu-entry> label linux arguments initrd)
(let ((linux-drv (package-derivation store linux system))
(initrd-drv (package-derivation store initrd system)))
;; XXX: Assume that INITRD is a directory containing an 'initrd' file.
(format #f "menuentry ~s {
linux ~a/bzImage ~a
initrd ~a/initrd
}~%"
label
(derivation-path->output-path linux-drv)
(string-join arguments)
(derivation-path->output-path initrd-drv))))))
(add-text-to-store store "grub.cfg"
(string-append prologue
(string-concatenate
(map entry->text entries)))
'()))

109
gnu/packages/gstreamer.scm 100644
View File

@ -0,0 +1,109 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU 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.
;;;
;;; GNU 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 GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu packages gstreamer)
#:use-module ((guix licenses) #:select (lgpl2.0+))
#:use-module (guix packages)
#:use-module (guix download)
#:use-module (guix build-system gnu)
#:use-module (gnu packages bison)
#:use-module (gnu packages flex)
#:use-module (gnu packages glib)
#:use-module (gnu packages perl)
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages python))
(define-public gstreamer
(package
(name "gstreamer")
(version "1.0.10")
(source
(origin
(method url-fetch)
(uri (string-append "http://gstreamer.freedesktop.org/src/gstreamer/gstreamer-"
version ".tar.xz"))
(sha256
(base32
"0c0irk85jd2cihm5pmf4zxhlpg08qpxjcqv1l9qn2n3h2gsaj2lf"))))
(build-system gnu-build-system)
(inputs
`(("bison" ,bison)
("flex" ,flex)
("glib" ,glib)
("perl" ,perl)
("pkg-config" ,pkg-config)
("python-wrapper" ,python-wrapper)))
(home-page "http://gstreamer.freedesktop.org/")
(synopsis
"Multimedia library")
(description
"GStreamer is a library for constructing graphs of media-handling
components. The applications it supports range from simple Ogg/Vorbis
playback, audio/video streaming to complex audio (mixing) and video
(non-linear editing) processing.
Applications can take advantage of advances in codec and filter technology
transparently. Developers can add new codecs and filters by writing a
simple plugin with a clean, generic interface.
This package provides the core library and elements.")
(license lgpl2.0+)))
(define-public gst-plugins-base
(package
(name "gst-plugins-base")
(version "1.0.10")
(source
(origin
(method url-fetch)
(uri (string-append "http://gstreamer.freedesktop.org/src/gst-plugins-base/gst-plugins-base-"
version ".tar.xz"))
(sha256
(base32
"1s4pphbb5kpdh4rrmb8rala4sp499k4by59925k15xiz58xyhm4p"))))
(build-system gnu-build-system)
;; FIXME: Add more dependencies for further plugins.
(inputs
`(("glib" ,glib)
("gstreamer" ,gstreamer)
("pkg-config" ,pkg-config)
("python-wrapper" ,python-wrapper)))
(arguments
`(#:tests? #f))
;; All tests pass except for one:
;; Running suite(s): pbutils library
;; 85%: Checks: 7, Failures: 1, Errors: 0
;; libs/pbutils.c:522:F:general:test_pb_utils_install_plugins:0: gst_install_plugins_sync() failed ;; with unexpected ret 201, which is neither HELPER_MISSING nor 1
;; FAIL: libs/pbutils
;; According to the documentation, "gst_install_plugins_sync (...)
;; should almost never be used".
(home-page "http://gstreamer.freedesktop.org/")
(synopsis
"Plugins for the gstreamer multimedia library")
(description
"GStreamer is a library for constructing graphs of media-handling
components. The applications it supports range from simple Ogg/Vorbis
playback, audio/video streaming to complex audio (mixing) and video
(non-linear editing) processing.
Applications can take advantage of advances in codec and filter technology
transparently. Developers can add new codecs and filters by writing a
simple plugin with a clean, generic interface.
This package provides an essential exemplary set of elements.")
(license lgpl2.0+)))

4
gnu/packages/gtk.scm
View File

@ -83,7 +83,7 @@ tools have full access to view and control running applications.")
("libspectre" ,libspectre)
("pkg-config" ,pkg-config)
("poppler" ,poppler)
("python" ,python)
("python" ,python-wrapper)
("xextproto" ,xextproto)
("zlib" ,zlib)))
(arguments
@ -123,7 +123,7 @@ affine transformation (scale, rotation, shear, etc.)")
`(("cairo" ,cairo)
("icu4c" ,icu4c)
("pkg-config" ,pkg-config)
("python" ,python)))
("python" ,python-wrapper)))
(synopsis "opentype text shaping engine")
(description
"HarfBuzz is an OpenType text shaping engine.")

2
gnu/packages/libevent.scm
View File

@ -44,7 +44,7 @@
;; Dependencies used for the tests and for `event_rpcgen.py'.
("which" ,which)
("python" ,python)))
("python" ,python-wrapper)))
(arguments
'(#:patches (list (assoc-ref %build-inputs "patch/dns-tests"))))
(home-page "http://libevent.org/")

3
gnu/packages/linux-initrd.scm
View File

@ -386,7 +386,8 @@ the Linux kernel.")
(chroot "/root")
(primitive-load to-load)
(format (current-error-port)
"boot program '~a' terminated, rebooting~%")
"boot program '~a' terminated, rebooting~%"
to-load)
(sleep 2)
(reboot))
(begin

10
gnu/packages/linux.scm
View File

@ -214,6 +214,11 @@
(license gpl2)
(home-page "http://www.gnu.org/software/linux-libre/"))))
;;;
;;; Pluggable authentication modules (PAM).
;;;
(define-public linux-pam
(package
(name "linux-pam")
@ -255,6 +260,11 @@ be used through the PAM API to perform tasks, like authenticating a user
at login. Local and dynamic reconfiguration are its key features")
(license bsd-3)))
;;;
;;; Miscellaneous.
;;;
(define-public psmisc
(package
(name "psmisc")

91
gnu/packages/mailutils.scm → gnu/packages/mail.scm
View File

@ -16,20 +16,23 @@
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu packages mailutils)
(define-module (gnu packages mail)
#:use-module (gnu packages)
#:use-module (gnu packages linux)
#:use-module (gnu packages gnutls)
#:use-module (gnu packages gdbm)
#:use-module (gnu packages guile)
#:use-module (gnu packages ncurses)
#:use-module (gnu packages readline)
#:use-module (gnu packages dejagnu)
#:use-module (gnu packages m4)
#:use-module (gnu packages texinfo)
#:use-module (gnu packages mysql)
#:use-module (gnu packages autotools)
#:use-module (guix licenses)
#:use-module (gnu packages dejagnu)
#:use-module (gnu packages gdbm)
#:use-module (gnu packages gnutls)
#:use-module (gnu packages guile)
#:use-module (gnu packages linux)
#:use-module (gnu packages m4)
#:use-module (gnu packages mysql)
#:use-module (gnu packages ncurses)
#:use-module (gnu packages openssl)
#:use-module (gnu packages perl)
#:use-module (gnu packages readline)
#:use-module (gnu packages texinfo)
#:use-module ((guix licenses)
#:select (gpl2+ gpl3+ lgpl3+))
#:use-module (guix packages)
#:use-module (guix download)
#:use-module (guix build-system gnu))
@ -104,3 +107,67 @@ message handling system.")
(license
;; Libraries are under LGPLv3+, and programs under GPLv3+.
(list gpl3+ lgpl3+))))
(define-public fetchmail
(package
(name "fetchmail")
(version "6.3.26")
(source (origin
(method url-fetch)
(uri (string-append "mirror://sourceforge/fetchmail/branch_6.3/fetchmail-"
version ".tar.xz"))
(sha256
(base32
"0l78ayvi9dm8hd190gl139cs2xqsrf7r9ncilslw20mgvd6cbd3r"))))
(build-system gnu-build-system)
(inputs
`(("openssl" ,openssl)))
(arguments
`(#:configure-flags (list (string-append "--with-ssl="
(assoc-ref %build-inputs "openssl")))))
(home-page "http://fetchmail.berlios.de/")
(synopsis "Remote-mailr etrieval and forwarding utility")
(description
"Fetchmail is a full-featured, robust, well-documented remote-mail
retrieval and forwarding utility intended to be used over on-demand
TCP/IP links (such as SLIP or PPP connections). It supports every
remote-mail protocol now in use on the Internet: POP2, POP3, RPOP, APOP,
KPOP, all flavors of IMAP, ETRN, and ODMR. It can even support IPv6
and IPSEC.
Fetchmail retrieves mail from remote mail servers and forwards it via SMTP,
so it can then be read by normal mail user agents such as mutt, elm
or BSD Mail. It allows all your system MTA's filtering, forwarding, and
aliasing facilities to work just as they would on normal mail.")
(license gpl2+))) ; most files are actually public domain or x11
(define-public mutt
(package
(name "mutt")
(version "1.5.21")
(source (origin
(method url-fetch)
(uri (string-append "ftp://ftp.mutt.org/mutt/devel/mutt-"
version ".tar.gz"))
(sha256
(base32
"1864cwz240gh0zy56fb47qqzwyf6ghg01037rb4p2kqgimpg6h91"))))
(build-system gnu-build-system)
(inputs
`(("ncurses" ,ncurses)
("openssl" ,openssl)
("perl" ,perl)))
(arguments
`(#:configure-flags '("--enable-smtp"
"--enable-imap"
"--enable-pop"
"--with-ssl"
;; so that mutt does not check whether the path
;; exists, which it does not in the chroot
"--with-mailpath=/var/mail")))
(home-page "http://www.mutt.org/")
(synopsis "Mail client")
(description
"Mutt is a small but very powerful text-based mail client for Unix
operating systems.")
(license gpl2+)))

2
gnu/packages/netpbm.scm
View File

@ -57,7 +57,7 @@
("libxml2" ,libxml2)
("perl" ,perl)
("pkg-config" ,pkg-config)
("python" ,python)
("python" ,python-wrapper)
("zlib" ,zlib)))
(arguments
`(#:phases

2
gnu/packages/oggvorbis.scm
View File

@ -191,7 +191,7 @@ meaning that audio is compressed in FLAC without any loss in quality.")
("libogg" ,libogg)
("libpng" ,libpng)
("pkg-config" ,pkg-config)
("python" ,python)
("python" ,python-wrapper)
("zlib" ,zlib)))
(synopsis "kate, a karaoke and text codec for embedding in ogg")
(description

12
gnu/packages/patches/avahi-localstatedir.patch 100644
View File

@ -0,0 +1,12 @@
Don't "mkdir $(localstatedir)" since we can't do it (/var).
--- avahi-0.6.27/avahi-daemon/Makefile.in 2010-07-13 05:06:35.000000000 +0200
+++ avahi-0.6.27/avahi-daemon/Makefile.in 2010-07-13 18:03:45.000000000 +0200
@@ -1554,7 +1554,6 @@ xmllint:
done
install-data-local:
- test -z "$(localstatedir)/run" || $(mkdir_p) "$(DESTDIR)$(localstatedir)/run"
update-systemd:
curl http://cgit.freedesktop.org/systemd/plain/src/sd-daemon.c > sd-daemon.c

30
gnu/packages/patches/dbus-localstatedir.patch 100644
View File

@ -0,0 +1,30 @@
Do not try to create $localstatedir and $sysconfdir since we cannot do this
when they are /var and /etc.
--- dbus-1.6.4/bus/Makefile.in 2013-09-11 16:15:13.000000000 +0200
+++ dbus-1.6.4/bus/Makefile.in 2013-09-11 16:15:15.000000000 +0200
@@ -1510,9 +1510,6 @@ clean-local:
/bin/rm *.bb *.bbg *.da *.gcov || true
install-data-hook:
- $(mkinstalldirs) $(DESTDIR)$(localstatedir)/run/dbus
- $(mkinstalldirs) $(DESTDIR)$(configdir)/system.d
- $(mkinstalldirs) $(DESTDIR)$(configdir)/session.d
$(mkinstalldirs) $(DESTDIR)$(datadir)/dbus-1/services
$(mkinstalldirs) $(DESTDIR)$(datadir)/dbus-1/system-services
# Install dbus.socket as default implementation of a D-Bus stack.
--- dbus-1.6.4/tools/Makefile.in 2013-09-11 16:10:31.000000000 +0200
+++ dbus-1.6.4/tools/Makefile.in 2013-09-11 16:10:32.000000000 +0200
@@ -757,11 +757,6 @@ uninstall-am: uninstall-binPROGRAMS
# create the /var/lib/dbus directory for dbus-uuidgen
-install-data-local:
- $(MKDIR_P) $(DESTDIR)$(localstatedir)/lib/dbus
-
-installcheck-local:
- test -d $(DESTDIR)$(localstatedir)/lib/dbus
# Tell versions [3.59,3.63) of GNU make to not export all variables.
# Otherwise a system limit (for SysV at least) may be exceeded.

36
gnu/packages/patches/gnutls-fix-tests-on-32-bits-system.patch
View File

@ -1,36 +0,0 @@
From b12040aeab5fbaf02677571db1d8bf1995bd5ee0 Mon Sep 17 00:00:00 2001
From: Nikos Mavrogiannopoulos <nmav@gnutls.org>
Date: Sun, 2 Jun 2013 12:10:06 +0200
Subject: [PATCH] Avoid comparing the expiration date to prevent false positive
error in 32-bit systems.
---
tests/cert-tests/pem-decoding | 6 ++++--
1 files changed, 4 insertions(+), 2 deletions(-)
diff --git a/tests/cert-tests/pem-decoding b/tests/cert-tests/pem-decoding
index fe769ec..f8c6372 100755
--- tests/cert-tests/pem-decoding
+++ tests/cert-tests/pem-decoding
@@ -61,7 +61,9 @@ if test "$rc" != "0"; then
exit $rc
fi
-diff $srcdir/complex-cert.pem tmp-pem.pem
+cat $srcdir/complex-cert.pem |grep -v "Not After:" >tmp1
+cat $srcdir/tmp-pem.pem |grep -v "Not After:" >tmp2
+diff tmp1 tmp2
rc=$?
if test "$rc" != "0"; then
@@ -69,6 +71,6 @@ if test "$rc" != "0"; then
exit $rc
fi
-rm -f tmp-pem.pem
+rm -f tmp-pem.pem tmp1 tmp2
exit 0
--
1.7.1

254
gnu/packages/python.scm
View File

@ -19,19 +19,25 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu packages python)
#:use-module ((guix licenses) #:select (bsd-3 psfl x11))
#:use-module ((guix licenses) #:select (bsd-3 bsd-style psfl x11))
#:use-module ((guix licenses) #:select (zlib)
#:renamer (symbol-prefix-proc 'license:))
#:use-module (gnu packages)
#:use-module (gnu packages compression)
#:use-module (gnu packages gdbm)
#:use-module (gnu packages icu4c)
#:use-module (gnu packages readline)
#:use-module (gnu packages openssl)
#:use-module (gnu packages patchelf)
#:use-module (gnu packages sqlite)
#:use-module (guix packages)
#:use-module (guix download)
#:use-module (guix utils)
#:use-module (guix build-system gnu)
#:use-module (guix build-system python))
#:use-module (guix build-system python)
#:use-module (guix build-system trivial))
(define-public python
(define-public python-2
(package
(name "python")
(version "2.7.5")
@ -151,8 +157,8 @@ packages; exception-based error handling; and very high level dynamic
data types.")
(license psfl)))
(define-public python-3
(package (inherit python)
(define-public python
(package (inherit python-2)
(version "3.3.2")
(source
(origin
@ -167,9 +173,34 @@ data types.")
(variable "PYTHONPATH")
(directories '("lib/python3.3/site-packages")))))))
(define-public pytz
(define-public python-wrapper
(package (inherit python)
(name "python-wrapper")
(source #f)
(build-system trivial-build-system)
(inputs `(("python" ,python)))
(arguments
`(#:modules ((guix build utils))
#:builder
(begin
(use-modules (guix build utils))
(let ((bin (string-append (assoc-ref %outputs "out") "/bin"))
(python (string-append (assoc-ref %build-inputs "python") "/bin/")))
(mkdir-p bin)
(for-each
(lambda (old new)
(symlink (string-append python old)
(string-append bin "/" new)))
`("python3", "pydoc3", "idle3")
`("python", "pydoc", "idle"))))))
(description (string-append (package-description python)
"\n\nThis wrapper package provides symbolic links to the python binaries
without version suffix."))))
(define-public python-pytz
(package
(name "pytz")
(name "python-pytz")
(version "2013b")
(source
(origin
@ -180,6 +211,7 @@ data types.")
(base32
"19giwgfcrg0nr1gdv49qnmf2jb2ilkcfc7qyqvfpz4dp0p64ksv5"))))
(build-system python-build-system)
(arguments `(#:tests? #f)) ; no test target
(home-page "https://launchpad.net/pytz")
(synopsis "The Python timezone library.")
(description
@ -187,22 +219,28 @@ data types.")
using Python 2.4 or higher and provides access to the Olson timezone database.")
(license x11)))
(define-public babel
(define-public python2-pytz
(package-with-python2 python-pytz))
(define-public python-babel
(package
(name "babel")
(version "0.9.6")
(name "python-babel")
(version "1.3")
(source
(origin
(method url-fetch)
(uri (string-append "http://ftp.edgewall.com/pub/babel/Babel-"
(uri (string-append "https://pypi.python.org/packages/source/B/Babel/Babel-"
version ".tar.gz"))
(sha256
(base32
"03vmr54jq5vf3qw6kpdv7cdk7x7i2jhzyf1mawv2gk8zrxg0hfja"))))
"0bnin777lc53nxd1hp3apq410jj5wx92n08h7h4izpl4f4sx00lz"))))
(build-system python-build-system)
(inputs
`(("pytz" ,pytz)))
(home-page "http://babel.edgewall.org/")
`(("python-pytz" ,python-pytz)
("python-setuptools" ,python-setuptools)))
(arguments `(#:tests? #f)) ; no test target
(home-page "http://babel.pocoo.org/")
(synopsis
"Tools for internationalizing Python applications")
(description
@ -212,3 +250,191 @@ using Python 2.4 or higher and provides access to the Olson timezone database.")
access to various locale display names, localized number and date formatting,
etc. ")
(license bsd-3)))
(define-public python2-babel
(package-with-python2 python-babel))
(define-public python-setuptools
(package
(name "python-setuptools")
(version "1.1.4")
(source
(origin
(method url-fetch)
(uri (string-append "https://pypi.python.org/packages/source/s/setuptools/setuptools-"
version ".tar.gz"))
(sha256
(base32
"0hl9sa5xr9bi2ifq51wy1bawsjv5nzvpbac7m9z1ciz778874csf"))))
(build-system python-build-system)
(arguments
`(#:tests? #f))
;;FIXME: test_sdist_with_utf8_encoded_filename fails in
;; /tmp/nix-build-python2-setuptools-1.1.4.drv-0/setuptools-1.1.4/setuptools/tests/test_sdist.py"
;; line 354
;; The tests pass with Python 2.7.5.
(home-page "https://pypi.python.org/pypi/setuptools")
(synopsis
"Library designed to facilitate packaging Python projects")
(description
"Setuptools is a fully-featured, stable library designed to facilitate
packaging Python projects, where packaging includes:
Python package and module definitions,
distribution package metadata,
test hooks,
project installation,
platform-specific details,
Python 3 support.")
(license psfl)))
(define-public python2-setuptools
(package-with-python2 python-setuptools))
(define-public python-dateutil
(package
(name "python-dateutil")
(version "1.5") ; last version for python < 3
(source
(origin
(method url-fetch)
(uri (string-append "http://labix.org/download/python-dateutil/python-dateutil-"
version ".tar.gz"))
(sha256
(base32
"0fqfglhy5khbvsipr3x7m6bcaqljh8xl5cw33vbfxy7qhmywm2n0"))))
(build-system python-build-system)
(inputs
`(("python-setuptools" ,python-setuptools)))
(home-page "http://labix.org/python-dateutil")
(synopsis
"Extensions to the standard datetime module, available in Python 2.3+")
(description
"The dateutil module provides powerful extensions to the standard
datetime module, available in Python 2.3+.")
(license psfl)))
(define-public python2-dateutil
(package-with-python2 python-dateutil))
(define-public python2-pysqlite
(package
(name "python2-pysqlite")
(version "2.6.3")
(source
(origin
(method url-fetch)
(uri (string-append "http://pysqlite.googlecode.com/files/pysqlite-"
version ".tar.gz"))
(sha256
(base32
"0nsqqfp072rgqbls100rdvbzkjkin7li3kprhfxlfqvzf608hlqd"))))
(build-system python-build-system)
(inputs
`(("sqlite" ,sqlite)))
(arguments
`(#:python ,python-2 ; incompatible with Python 3
#:tests? #f)) ; no test target
(home-page "http://labix.org/python-dateutil")
(synopsis
"SQLite bindings for Python.")
(description
"Pysqlite provides SQLite bindings for Python that comply to the
Database API 2.0T.")
(license license:zlib)))
(define-public python2-mechanize
(package
(name "python2-mechanize")
(version "0.2.5")
(source
(origin
(method url-fetch)
(uri (string-append "https://pypi.python.org/packages/source/m/mechanize/mechanize-"
version ".tar.gz"))
(sha256
(base32
"0rj7r166i1dyrq0ihm5rijfmvhs8a04im28lv05c0c3v206v4rrf"))))
(build-system python-build-system)
(inputs
`(("python2-setuptools" ,python2-setuptools)))
(arguments
`(#:python ,python-2 ; apparently incompatible with Python 3
#:tests? #f))
;; test fails with message
;; AttributeError: 'module' object has no attribute 'test_pullparser'
;; (python-3.3.2) or
;; AttributeError: 'module' object has no attribute 'test_urllib2_localnet'
;; (python-2.7.5).
;; The source code is from March 2011 and probably not up-to-date
;; with respect to python unit tests.
(home-page "http://wwwsearch.sourceforge.net/mechanize/")
(synopsis
"Stateful programmatic web browsing in Python")
(description
"Mechanize implements stateful programmatic web browsing in Python,
after Andy Lester’s Perl module WWW::Mechanize.")
(license (bsd-style "file://COPYING"
"See COPYING in the distribution."))))
(define-public python-simplejson
(package
(name "python-simplejson")
(version "3.3.0")
(source
(origin
(method url-fetch)
(uri (string-append "https://pypi.python.org/packages/source/s/simplejson/simplejson-"
version ".tar.gz"))
(sha256
(base32
"07wsry5j44l5zzm74l4j2bvasiq8n5m32f31n2p7c68i5vc6p2ks"))))
(build-system python-build-system)
(home-page "http://simplejson.readthedocs.org/en/latest/")
(synopsis
"Json library for Python")
(description
"JSON (JavaScript Object Notation) is a subset of JavaScript syntax
(ECMA-262 3rd edition) used as a lightweight data interchange format.
Simplejson exposes an API familiar to users of the standard library marshal
and pickle modules. It is the externally maintained version of the json
library contained in Python 2.6, but maintains compatibility with Python 2.5
and (currently) has significant performance advantages, even without using
the optional C extension for speedups. Simplejson is also supported on
Python 3.3+.")
(license x11)))
(define-public python2-simplejson
(package-with-python2 python-simplejson))
(define-public python2-pyicu
(package
(name "python2-pyicu")
(version "1.5")
(source
(origin
(method url-fetch)
(uri (string-append "https://pypi.python.org/packages/source/P/PyICU/PyICU-"
version ".tar.gz"))
(sha256
(base32
"011vwflpir8wvh48mvi6d9a7vw0f43bkwv0w6bzxbzmvz20ax5vm"))))
(build-system python-build-system)
(inputs
`(("icu4c" ,icu4c)))
(arguments
`(#:python ,python-2 ; Python 3 works also, but needs special care for
; linking with libpython3.3m
#:tests? #f)) ; no check target
(home-page "http://pyicu.osafoundation.org/")
(synopsis
"Python extension wrapping the ICU C++ API.")
(description
"PyICU is a python extension wrapping the ICU C++ API.")
(license x11)))

2
gnu/packages/qemu.scm
View File

@ -94,7 +94,7 @@
`(;; ("mesa" ,mesa)
;; ("libaio" ,libaio)
("glib" ,glib)
("python" ,python)
("python" ,python-2) ; incompatible with Python 3 according to error message
("ncurses" ,ncurses)
("libpng" ,libpng)
("libjpeg" ,libjpeg-8)

2
gnu/packages/samba.scm
View File

@ -150,7 +150,7 @@ anywhere.")
("patchelf" ,patchelf))) ; for (guix build rpath)
(native-inputs ; for the test suite
`(("perl" ,perl)
("python" ,python)))
("python" ,python-wrapper)))
(home-page "http://www.samba.org/")
(synopsis
"The standard Windows interoperability suite of programs for GNU and Unix")

34
gnu/packages/system.scm
View File

@ -25,7 +25,39 @@
#:use-module (guix build-system gnu)
#:use-module (gnu packages)
#:use-module (gnu packages ncurses)
#:use-module (gnu packages linux))
#:use-module (gnu packages linux)
#:use-module (gnu packages guile)
#:use-module (gnu packages pkg-config))
(define-public dmd
(package
(name "dmd")
(version "-0.4")
(source (origin
(method url-fetch)
;; XXX: Temporary location until dmd gets back home.
(uri (string-append
"http://www.fdn.fr/~lcourtes/software/guix/dmd-"
version ".tar.gz"))
(sha256
(base32
"094ja3xvk9ljghhxmy39if67cfjd1hy6m4svnp399n0wpxvaryvy"))))
(build-system gnu-build-system)
(arguments
'(#:configure-flags '("--localstatedir=/var")))
(inputs `(("pkg-config" ,pkg-config)
("guile" ,guile-2.0)))
(synopsis "Daemon managing daemons")
(description "'DMD' is a \"Daemon managing Daemons\" (or
\"Daemons-managing Daemon\"?)---i.e. a service manager that provides a
replacement for the service-managing capabilities of SysV-init (or any other
init) with a both powerful and beautiful dependency-based system with a
convenient interface. It is intended for use on GNU/Hurd, but it is supposed
to work on every POSIX-like system where Guile is available. In particular,
it has been tested on GNU/Linux.")
(license gpl3+)
(home-page "http://www.gnu.org/software/dmd/")))
(define-public dfc
(package

4
gnu/packages/texlive.scm
View File

@ -81,7 +81,7 @@
("pkg-config" ,pkg-config)
;; FIXME: Add interpreters fontforge and ruby,
;; once they are available.
("python" ,python)
("python" ,python-2) ; incompatible with Python 3 (print syntax)
("tcsh" ,tcsh)
("teckit" ,teckit)
("t1lib" ,t1lib)
@ -202,7 +202,7 @@ world.")
(build-system gnu-build-system)
(arguments '(#:tests? #f)) ; no `check' target
(inputs `(("texinfo" ,texinfo)
("python" ,python)
("python" ,python-2) ; incompatible with Python 3 (print syntax)
("which" ,which)))
(home-page "https://launchpad.net/rubber")
(synopsis "Rubber, a wrapper for LaTeX and friends")

8
gnu/packages/version-control.scm
View File

@ -58,7 +58,9 @@
;; require Zsh.
`(("gettext" ,guix:gettext)))
(arguments
`(#:tests? #f)) ; no test target
`(#:tests? #f ; no test target
#:python ,python-2)) ; Python 3 apparently not yet supported, see
; https://answers.launchpad.net/bzr/+question/229048
(home-page "https://gnu.org/software/bazaar")
(synopsis "Decentralized revision control system")
(description
@ -86,7 +88,7 @@ from a command line or use a GUI application.")
("gettext" ,guix:gettext)
("openssl" ,openssl)
("perl" ,perl)
("python" ,python) ; CAVEAT: incompatible with python-3 according to INSTALL
("python" ,python-2) ; CAVEAT: incompatible with python-3 according to INSTALL
("zlib" ,zlib)))
(arguments
`(#:make-flags `("V=1") ; more verbose compilation
@ -126,7 +128,7 @@ everything from small to very large projects with speed and efficiency.")
`(("apr" ,apr)
("apr-util" ,apr-util)
("perl" ,perl)
("python" ,python)
("python" ,python-2) ; incompatible with Python 3 (print syntax)
("sqlite" ,sqlite)
("zlib" ,zlib)))
(home-page "http://subversion.apache.org/")

4
gnu/packages/xml.scm
View File

@ -66,7 +66,7 @@ things the parser might find in the XML document (like start tags).")
(home-page "http://www.xmlsoft.org/")
(synopsis "libxml2, a C parser for XML")
(inputs `(("perl" ,perl)
("python" ,python)
("python" ,python-2) ; incompatible with Python 3 (print syntax)
("zlib" ,zlib)))
(arguments
`(#:phases
@ -102,7 +102,7 @@ things the parser might find in the XML document (like start tags).")
(synopsis "libxslt, a C library for applying XSLT stylesheets to XML documents")
(inputs `(("libgcrypt" ,libgcrypt)
("libxml2" ,libxml2)
("python" ,python)
("python" ,python-wrapper)
("zlib" ,zlib)))
(description
"Libxslt is an XSLT C library developed for the GNOME project. It is

13
gnu/packages/xorg.scm
View File

@ -1857,7 +1857,7 @@ tracking.")
"0ds4qg6slidrzyz6q9ckq0a19hn6blzpnvciy4brh741gn49jpdd"))))
(build-system gnu-build-system)
(inputs
`(("pkg-config" ,pkg-config) ("python" ,python)))
`(("pkg-config" ,pkg-config) ("python" ,python-wrapper)))
(home-page "http://www.x.org/wiki/")
(synopsis "xorg implementation of the X Window System")
(description "X.org provides an implementation of the X Window System")
@ -1929,6 +1929,11 @@ tracking.")
`(("libxcursor" ,libxcursor)
("pkg-config" ,pkg-config)
("xcursorgen" ,xcursorgen)))
(arguments
`(#:configure-flags
(list (string-append "--with-cursordir="
(assoc-ref %outputs "out")
"/share/icons"))))
(home-page "http://www.x.org/wiki/")
(synopsis "xorg implementation of the X Window System")
(description "X.org provides an implementation of the X Window System")
@ -4169,7 +4174,7 @@ tracking.")
("libxml2" ,libxml2)
("makedepend" ,makedepend)
("pkg-config" ,pkg-config)
("python" ,python)))
("python" ,python-2))) ; incompatible with Python 3 (print syntax)
(arguments
`(#:configure-flags
`("--with-gallium-drivers=r600,svga,swrast") ; drop r300 from the default list as it requires llvm
@ -4215,7 +4220,7 @@ emulation to complete hardware acceleration for modern GPUs.")
`(("xcb-proto" ,xcb-proto)
("libxslt" ,libxslt)
("pkg-config" ,pkg-config)
("python" ,python)))
("python" ,python-wrapper)))
(home-page "http://www.x.org/wiki/")
(synopsis "xorg implementation of the X Window System")
(description "X.org provides an implementation of the X Window System")
@ -4270,7 +4275,7 @@ emulation to complete hardware acceleration for modern GPUs.")
("mesa" ,mesa)
("openssl" ,openssl)
("pkg-config" ,pkg-config)
("python" ,python)
("python" ,python-wrapper)
("recordproto" ,recordproto)
("resourceproto" ,resourceproto)
("scrnsaverproto" ,scrnsaverproto)

2
gnu/packages/yasm.scm
View File

@ -40,7 +40,7 @@
"0cfg7ji3ia2in628w42wrfvw2ixmmm4rghwmv2k202mraysgm3vn"))))
(build-system gnu-build-system)
(inputs
`(("python" ,python)
`(("python" ,python-wrapper)
("xmlto" ,xmlto)))
(home-page "http://yasm.tortall.net/")
(synopsis "Rewrite of the NASM assembler")

3
gnu/packages/zip.scm
View File

@ -120,7 +120,8 @@ UnZip recreates the stored directory structure by default.")
(build-system gnu-build-system)
(inputs `(("perl" ,perl) ; for the documentation
("pkg-config" ,pkg-config)
("python" ,python) ; for the documentation
("python" ,python-2) ; for the documentation; Python 3 not supported,
; http://forums.gentoo.org/viewtopic-t-863161-start-0.html
("zip" ,zip) ; to create test files
("zlib" ,zlib)))
(arguments

126
gnu/system/dmd.scm 100644
View File

@ -0,0 +1,126 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU 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.
;;;
;;; GNU 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 GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu system dmd)
#:use-module (guix store)
#:use-module (guix packages)
#:use-module (guix derivations)
#:use-module (guix records)
#:use-module ((gnu packages system)
#:select (mingetty inetutils))
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:export (service?
service
service-provision
service-requirement
service-respawn?
service-start
service-stop
service-inputs
syslog-service
mingetty-service
dmd-configuration-file))
;;; Commentary:
;;;
;;; System services as cajoled by dmd.
;;;
;;; Code:
(define-record-type* <service>
service make-service
service?
(provision service-provision) ; list of symbols
(requirement service-requirement ; list of symbols
(default '()))
(respawn? service-respawn? ; Boolean
(default #t))
(start service-start) ; expression
(stop service-stop ; expression
(default #f))
(inputs service-inputs ; list of inputs
(default '())))
(define (mingetty-service store tty)
"Return a service to run mingetty on TTY."
(let* ((mingetty-drv (package-derivation store mingetty))
(mingetty-bin (string-append (derivation->output-path mingetty-drv)
"/sbin/mingetty")))
(service
(provision (list (symbol-append 'term- (string->symbol tty))))
(start `(make-forkexec-constructor ,mingetty-bin "--noclear" ,tty))
(inputs `(("mingetty" ,mingetty))))))
(define (syslog-service store)
"Return a service that runs 'syslogd' with reasonable default settings."
(define syslog.conf
;; Snippet adapted from the GNU inetutils manual.
(add-text-to-store store "syslog.conf" "
# Log all kernel messages, authentication messages of
# level notice or higher and anything of level err or
# higher to the console.
# Don't log private authentication messages!
*.err;kern.*;auth.notice;authpriv.none /dev/console
# Log anything (except mail) of level info or higher.
# Don't log private authentication messages!
*.info;mail.none;authpriv.none /var/log/messages
# Same, in a different place.
*.info;mail.none;authpriv.none /dev/tty12
# The authpriv file has restricted access.
authpriv.* /var/log/secure
# Log all the mail messages in one place.
mail.* /var/log/maillog
"))
(let* ((inetutils-drv (package-derivation store inetutils))
(syslogd (string-append (derivation->output-path inetutils-drv)
"/libexec/syslogd")))
(service
(provision '(syslogd))
(start `(make-forkexec-constructor ,syslogd
"--rcfile" ,syslog.conf))
(inputs `(("inetutils" ,inetutils)
("syslog.conf" ,syslog.conf))))))
(define (dmd-configuration-file store services)
"Return the dmd configuration file for SERVICES."
(define config
`(begin
(register-services
,@(map (match-lambda
(($ <service> provision requirement respawn? start stop)
`(make <service>
#:provides ',provision
#:requires ',requirement
#:respawn? ,respawn?
#:start ,start
#:stop ,stop)))
services))
(for-each start ',(append-map service-provision services))))
(add-text-to-store store "dmd.conf"
(object->string config)))
;;; dmd.scm ends here

84
gnu/system/grub.scm 100644
View File

@ -0,0 +1,84 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU 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.
;;;
;;; GNU 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 GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu system grub)
#:use-module (guix store)
#:use-module (guix packages)
#:use-module (guix derivations)
#:use-module (guix records)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:export (menu-entry
menu-entry?
grub-configuration-file))
;;; Commentary:
;;;
;;; Configuration of GNU GRUB.
;;;
;;; Code:
(define-record-type* <menu-entry>
menu-entry make-menu-entry
menu-entry?
(label menu-entry-label)
(linux menu-entry-linux)
(linux-arguments menu-entry-linux-arguments
(default '()))
(initrd menu-entry-initrd))
(define* (grub-configuration-file store entries
#:key (default-entry 1) (timeout 5)
(system (%current-system)))
"Return the GRUB configuration file in STORE for ENTRIES, a list of
<menu-entry> objects, defaulting to DEFAULT-ENTRY and with the given TIMEOUT."
(define prologue
(format #f "
set default=~a
set timeout=~a
search.file ~a~%"
default-entry timeout
(any (match-lambda
(($ <menu-entry> _ linux)
(let* ((drv (package-derivation store linux system))
(out (derivation->output-path drv)))
(string-append out "/bzImage"))))
entries)))
(define entry->text
(match-lambda
(($ <menu-entry> label linux arguments initrd)
(let ((linux-drv (package-derivation store linux system))
(initrd-drv (package-derivation store initrd system)))
;; XXX: Assume that INITRD is a directory containing an 'initrd' file.
(format #f "menuentry ~s {
linux ~a/bzImage ~a
initrd ~a/initrd
}~%"
label
(derivation->output-path linux-drv)
(string-join arguments)
(derivation->output-path initrd-drv))))))
(add-text-to-store store "grub.cfg"
(string-append prologue
(string-concatenate
(map entry->text entries)))
'()))
;;; grub.scm ends here

145
gnu/system/linux.scm 100644
View File

@ -0,0 +1,145 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU 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.
;;;
;;; GNU 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 GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu system linux)
#:use-module (guix store)
#:use-module (guix records)
#:use-module (guix derivations)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module ((guix utils) #:select (%current-system))
#:export (pam-service
pam-entry
pam-services->directory
%pam-other-services
unix-pam-service))
;;; Commentary:
;;;
;;; Configuration of Linux-related things, including pluggable authentication
;;; modules (PAM).
;;;
;;; Code:
;; PAM services (see
;; <http://www.linux-pam.org/Linux-PAM-html/sag-configuration-file.html>.)
(define-record-type* <pam-service> pam-service
make-pam-service
pam-service?
(name pam-service-name) ; string
;; The four "management groups".
(account pam-service-account ; list of <pam-entry>
(default '()))
(auth pam-service-auth
(default '()))
(password pam-service-password
(default '()))
(session pam-service-session
(default '())))
(define-record-type* <pam-entry> pam-entry
make-pam-entry
pam-entry?
(control pam-entry-control) ; string
(module pam-entry-module) ; file name
(arguments pam-entry-arguments ; list of strings
(default '())))
(define (pam-service->configuration service)
"Return the configuration string for SERVICE, to be dumped in
/etc/pam.d/NAME, where NAME is the name of SERVICE."
(define (entry->string type entry)
(match entry
(($ <pam-entry> control module (arguments ...))
(string-append type " "
control " " module " "
(string-join arguments)
"\n"))))
(match service
(($ <pam-service> name account auth password session)
(string-concatenate
(append (map (cut entry->string "account" <>) account)
(map (cut entry->string "auth" <>) auth)
(map (cut entry->string "password" <>) password)
(map (cut entry->string "session" <>) session))))))
(define (pam-services->directory store services)
"Return the derivation to build the configuration directory to be used as
/etc/pam.d for SERVICES."
(let ((names (map pam-service-name services))
(files (map (match-lambda
((and service ($ <pam-service> name))
(let ((config (pam-service->configuration service)))
(add-text-to-store store
(string-append name ".pam")
config '()))))
services)))
(define builder
'(begin
(use-modules (ice-9 match))
(let ((out (assoc-ref %outputs "out")))
(mkdir out)
(for-each (match-lambda
((name . file)
(symlink file (string-append out "/" name))))
%build-inputs)
#t)))
(build-expression->derivation store "pam.d" (%current-system)
builder
(zip names files))))
(define %pam-other-services
;; The "other" PAM configuration, which denies everything (see
;; <http://www.linux-pam.org/Linux-PAM-html/sag-configuration-example.html>.)
(let ((deny (pam-entry
(control "required")
(module "pam_deny.so"))))
(pam-service
(name "other")
(account (list deny))
(auth (list deny))
(password (list deny))
(session (list deny)))))
(define unix-pam-service
(let ((unix (pam-entry
(control "required")
(module "pam_unix.so"))))
(lambda* (name #:key allow-empty-passwords?)
"Return a standard Unix-style PAM service for NAME. When
ALLOW-EMPTY-PASSWORDS? is true, allow empty passwords."
;; See <http://www.linux-pam.org/Linux-PAM-html/sag-configuration-example.html>.
(let ((name* name))
(pam-service
(name name*)
(account (list unix))
(auth (list (if allow-empty-passwords?
(pam-entry
(control "required")
(module "pam_unix.so")
(arguments '("nullok")))
unix)))
(password (list unix))
(session (list unix)))))))
;;; linux.scm ends here

57
gnu/system/shadow.scm 100644
View File

@ -0,0 +1,57 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU 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.
;;;
;;; GNU 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 GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu system shadow)
#:use-module (guix store)
#:use-module (ice-9 match)
#:export (passwd-file))
;;; Commentary:
;;;
;;; Utilities for configuring the Shadow tool suite ('login', 'passwd', etc.)
;;;
;;; Code:
(define* (passwd-file store accounts #:key shadow?)
"Return a password file for ACCOUNTS, a list of vectors as returned by
'getpwnam'. If SHADOW? is true, then it is a /etc/shadow file, otherwise it
is a /etc/passwd file."
;; XXX: The resulting file is world-readable, so beware when SHADOW? is #t!
(define contents
(let loop ((accounts accounts)
(result '()))
(match accounts
((#(name pass uid gid comment home-dir shell) rest ...)
(loop rest
(cons (if shadow?
(string-append name
":" ; XXX: use (crypt PASS …)?
":::::::")
(string-append name
":" "x"
":" (number->string uid)
":" (number->string gid)
":" comment ":" home-dir ":" shell))
result)))
(()
(string-join (reverse result) "\n" 'suffix)))))
(add-text-to-store store (if shadow? "shadow" "passwd")
contents '()))
;;; shadow.scm ends here

201
gnu/system/vm.scm
View File

@ -33,13 +33,20 @@
#:use-module (gnu packages linux-initrd)
#:use-module ((gnu packages make-bootstrap)
#:select (%guile-static-stripped))
#:use-module ((gnu packages system)
#:select (mingetty))
#:use-module (gnu packages system)
#:use-module (gnu system shadow)
#:use-module (gnu system linux)
#:use-module (gnu system grub)
#:use-module (gnu system dmd)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:export (expression->derivation-in-linux-vm
qemu-image))
qemu-image
system-qemu-image))
;;; Commentary:
@ -75,6 +82,9 @@ DISK-IMAGE-SIZE bytes and return it.
When REFERENCES-GRAPHS is true, it must be a list of file name/store path
pairs, as for `derivation'. The files containing the reference graphs are
made available under the /xchg CIFS share."
;; FIXME: Allow use of macros from other modules, as done in
;; `build-expression->derivation'.
(define input-alist
(map (match-lambda
((input (? package? package))
@ -197,10 +207,10 @@ It can be used to provide additional files, such as /etc files."
(define input->name+derivation
(match-lambda
((name (? package? package))
`(,name . ,(derivation-path->output-path
`(,name . ,(derivation->output-path
(package-derivation store package system))))
((name (? package? package) sub-drv)
`(,name . ,(derivation-path->output-path
`(,name . ,(derivation->output-path
(package-derivation store package system)
sub-drv)))
((input (and (? string?) (? store-path?) file))
@ -294,6 +304,19 @@ It can be used to provide additional files, such as /etc files."
(primitive-load populate)
(chdir "/")))
(display "clearing file timestamps...\n")
(for-each (lambda (file)
(let ((s (lstat file)))
;; XXX: Guile uses libc's 'utime' function
;; (not 'futime'), so the timestamp of
;; symlinks cannot be changed, and there
;; are symlinks here pointing to
;; /nix/store, which is the host,
;; read-only store.
(unless (eq? (stat:type s) 'symlink)
(utime file 0 0 0 0))))
(find-files "/fs" ".*"))
(and (zero?
(system* grub "--no-floppy"
"--boot-directory" "/fs/boot"
@ -327,100 +350,88 @@ It can be used to provide additional files, such as /etc files."
;;;
;;; Guile 2.0 potluck examples.
;;; Stand-alone VM image.
;;;
(define (example1)
(let ((store #f))
(dynamic-wind
(lambda ()
(set! store (open-connection)))
(lambda ()
(parameterize ((%guile-for-build (package-derivation store guile-final)))
(expression->derivation-in-linux-vm
store "vm-test"
'(begin
(display "hello from boot!\n")
(call-with-output-file "/xchg/hello"
(lambda (p)
(display "world" p)))))))
(lambda ()
(close-connection store)))))
(define (system-qemu-image store)
"Return the derivation of a QEMU image of the GNU system."
(define %pam-services
;; Services known to PAM.
(list %pam-other-services
(unix-pam-service "login" #:allow-empty-passwords? #t)))
(define (/etc/shadow store accounts)
"Return a /etc/shadow file for ACCOUNTS."
(define contents
(let loop ((accounts accounts)
(result '()))
(match accounts
(((name uid gid comment home-dir shell) rest ...)
(loop rest
(cons (string-append name "::" (number->string uid)
":" (number->string gid)
comment ":" home-dir ":" shell)
result)))
(()
(string-concatenate-reverse result)))))
(define %dmd-services
;; Services run by dmd.
(list (mingetty-service store "tty1")
(mingetty-service store "tty2")
(mingetty-service store "tty3")
(syslog-service store)))
(add-text-to-store store "shadow" contents '()))
(parameterize ((%guile-for-build (package-derivation store guile-final)))
(let* ((bash-drv (package-derivation store bash))
(bash-file (string-append (derivation->output-path bash-drv)
"/bin/bash"))
(dmd-drv (package-derivation store dmd))
(dmd-file (string-append (derivation->output-path dmd-drv)
"/bin/dmd"))
(dmd-conf (dmd-configuration-file store %dmd-services))
(accounts (list (vector "root" "" 0 0 "System administrator"
"/" bash-file)))
(passwd (passwd-file store accounts))
(shadow (passwd-file store accounts #:shadow? #t))
(group (add-text-to-store store "group"
"root:x:0:\n"))
(pam.d-drv (pam-services->directory store %pam-services))
(pam.d (derivation->output-path pam.d-drv))
(populate
(add-text-to-store store "populate-qemu-image"
(object->string
`(begin
(mkdir-p "etc")
(mkdir-p "var/log") ; for dmd
(symlink ,shadow "etc/shadow")
(symlink ,passwd "etc/passwd")
(symlink ,group "etc/group")
(symlink "/dev/null"
"etc/login.defs")
(symlink ,pam.d "etc/pam.d")
(mkdir-p "var/run")))
(list passwd)))
(out (derivation->output-path
(package-derivation store mingetty)))
(boot (add-text-to-store store "boot"
(object->string
`(execl ,dmd-file "dmd"
"--config" ,dmd-conf))
(list out)))
(entries (list (menu-entry
(label "Boot-to-Guile! (GNU System technology preview)")
(linux linux-libre)
(linux-arguments `("--root=/dev/vda1"
,(string-append "--load=" boot)))
(initrd gnu-system-initrd))))
(grub.cfg (grub-configuration-file store entries)))
(build-derivations store (list pam.d-drv))
(qemu-image store
#:grub-configuration grub.cfg
#:populate populate
#:disk-image-size (* 400 (expt 2 20))
#:inputs-to-copy `(("boot" ,boot)
("linux" ,linux-libre)
("initrd" ,gnu-system-initrd)
("coreutils" ,coreutils)
("bash" ,bash)
("guile" ,guile-2.0)
("mingetty" ,mingetty)
("dmd" ,dmd)
(define (example2)
(let ((store #f))
(dynamic-wind
(lambda ()
(set! store (open-connection)))
(lambda ()
(parameterize ((%guile-for-build (package-derivation store guile-final)))
(let* ((bash-drv (package-derivation store bash))
(bash-file (string-append (derivation-path->output-path bash-drv)
"/bin/bash"))
(passwd (/etc/shadow store
`(("root" 0 0 "System administrator" "/"
,bash-file))))
(populate
(add-text-to-store store "populate-qemu-image"
(object->string
`(begin
(mkdir-p "etc")
(symlink ,(substring passwd 1)
"etc/shadow")))
(list passwd)))
(out (derivation-path->output-path
(package-derivation store mingetty)))
(getty (string-append out "/sbin/mingetty"))
(boot (add-text-to-store store "boot"
(object->string
`(begin
;; Become the session leader,
;; so that mingetty can do
;; 'TIOCSCTTY'.
(setsid)
;; Directly into mingetty.
(execl ,getty "mingetty"
"--noclear" "tty1")))
(list out)))
(entries (list (menu-entry
(label "Boot-to-Guile! (GNU System technology preview)")
(linux linux-libre)
(linux-arguments `("--root=/dev/vda1"
,(string-append "--load=" boot)))
(initrd gnu-system-initrd))))
(grub.cfg (grub-configuration-file store entries)))
(qemu-image store
#:grub-configuration grub.cfg
#:populate populate
#:disk-image-size (* 400 (expt 2 20))
#:inputs-to-copy `(("boot" ,boot)
("linux" ,linux-libre)
("initrd" ,gnu-system-initrd)
("coreutils" ,coreutils)
("bash" ,bash)
("guile" ,guile-2.0)
("mingetty" ,mingetty)
("shadow" ,passwd))))))
(lambda ()
(close-connection store)))))
;; Configuration.
("dmd.conf" ,dmd-conf)
("etc-pam.d" ,pam.d)
("etc-passwd" ,passwd)
("etc-shadow" ,shadow)
("etc-group" ,group)
,@(append-map service-inputs
%dmd-services))))))
;;; vm.scm ends here

6
guix/build-system/cmake.scm
View File

@ -72,9 +72,9 @@ provides a 'CMakeLists.txt' file as its build system."
(define builder
`(begin
(use-modules ,@modules)
(cmake-build #:source ,(if (and source (derivation-path? source))
(derivation-path->output-path source)
source)
(cmake-build #:source ,(if (derivation? source)
(derivation->output-path source)
source)
#:system ,system
#:outputs %outputs
#:inputs %build-inputs

20
guix/build-system/gnu.scm
View File

@ -291,8 +291,8 @@ which could lead to gratuitous input divergence."
(define builder
`(begin
(use-modules ,@modules)
(gnu-build #:source ,(if (and source (derivation-path? source))
(derivation-path->output-path source)
(gnu-build #:source ,(if (derivation? source)
(derivation->output-path source)
source)
#:system ,system
#:outputs %outputs
@ -319,8 +319,8 @@ which could lead to gratuitous input divergence."
(match guile
((? package?)
(package-derivation store guile system))
((and (? string?) (? derivation-path?))
guile)
;; ((and (? string?) (? derivation-path?))
;; guile)
(#f ; the default
(let* ((distro (resolve-interface '(gnu packages base)))
(guile (module-ref distro 'guile-final)))
@ -438,6 +438,8 @@ platform."
(let ()
(define %build-host-inputs
',(map (match-lambda
((name (? derivation? drv) sub ...)
`(,name . ,(apply derivation->output-path drv sub)))
((name (? derivation-path? drv-path) sub ...)
`(,name . ,(apply derivation-path->output-path
drv-path sub)))
@ -447,6 +449,8 @@ platform."
(define %build-target-inputs
',(map (match-lambda
((name (? derivation? drv) sub ...)
`(,name . ,(apply derivation->output-path drv sub)))
((name (? derivation-path? drv-path) sub ...)
`(,name . ,(apply derivation-path->output-path
drv-path sub)))
@ -454,8 +458,8 @@ platform."
`(,name . ,path)))
(append (or implicit-target-inputs '()) inputs)))
(gnu-build #:source ,(if (and source (derivation-path? source))
(derivation-path->output-path source)
(gnu-build #:source ,(if (derivation? source)
(derivation->output-path source)
source)
#:system ,system
#:target ,target
@ -488,8 +492,8 @@ platform."
(match guile
((? package?)
(package-derivation store guile system))
((and (? string?) (? derivation-path?))
guile)
;; ((and (? string?) (? derivation-path?))
;; guile)
(#f ; the default
(let* ((distro (resolve-interface '(gnu packages base)))
(guile (module-ref distro 'guile-final)))

4
guix/build-system/perl.scm
View File

@ -62,8 +62,8 @@ provides a `Makefile.PL' file as its build system."
`(begin
(use-modules ,@modules)
(perl-build #:name ,name
#:source ,(if (and source (derivation-path? source))
(derivation-path->output-path source)
#:source ,(if (derivation? source)
(derivation->output-path source)
source)
#:search-paths ',(map search-path-specification->sexp
(append perl-search-paths

66
guix/build-system/python.scm
View File

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;;
;;; This file is part of GNU Guix.
@ -25,7 +26,9 @@
#:use-module (guix build-system)
#:use-module (guix build-system gnu)
#:use-module (ice-9 match)
#:export (python-build
#:use-module (srfi srfi-26)
#:export (package-with-python2
python-build
python-build-system))
;; Commentary:
@ -39,13 +42,60 @@
"Return the default Python package."
;; Lazily resolve the binding to avoid a circular dependency.
(let ((python (resolve-interface '(gnu packages python))))
(module-ref python 'python)))
(module-ref python 'python-wrapper)))
(define (default-python2)
"Return the default Python 2 package."
(let ((python (resolve-interface '(gnu packages python))))
(module-ref python 'python-2)))
(define (package-with-explicit-python p python old-prefix new-prefix)
"Create a package with the same fields as P, which is assumed to use
PYTHON-BUILD-SYSTEM, such that it is compiled with PYTHON instead. The
inputs are changed recursively accordingly. If the name of P starts with
OLD-PREFIX, this is replaced by NEW-PREFIX; otherwise, NEW-PREFIX is
prepended to the name."
(let* ((build-system (package-build-system p))
(rewrite-if-package
(lambda (content)
;; CONTENT may be a string (e.g., for patches), in which case it
;; is returned, or a package, which is rewritten with the new
;; PYTHON and NEW-PREFIX.
(if (package? content)
(package-with-explicit-python content python
old-prefix new-prefix)
content)))
(rewrite
(match-lambda
((name content . rest)
(append (list name (rewrite-if-package content)) rest)))))
(package (inherit p)
(name
(let ((name (package-name p)))
(if (eq? build-system python-build-system)
(string-append new-prefix
(if (string-prefix? old-prefix name)
(substring name (string-length old-prefix))
name))
name)))
(arguments
(let ((arguments (package-arguments p)))
(if (eq? build-system python-build-system)
(if (member #:python arguments)
(substitute-keyword-arguments arguments ((#:python p) python))
(append arguments `(#:python ,python)))
arguments)))
(inputs
(map rewrite (package-inputs p)))
(native-inputs
(map rewrite (package-native-inputs p))))))
(define package-with-python2
(cut package-with-explicit-python <> (default-python2) "python-" "python2-"))
(define* (python-build store name source inputs
#:key
(python (default-python))
(python-version
(string-take (package-version (default-python)) 3))
(tests? #t)
(configure-flags ''())
(phases '(@ (guix build python-build-system)
@ -58,10 +108,10 @@
(guix build gnu-build-system)
(guix build utils)))
(modules '((guix build python-build-system)
(guix build gnu-build-system)
(guix build utils))))
"Build SOURCE using PYTHON, and with INPUTS. This assumes that SOURCE
provides a 'setup.py' file as its build system."
(define python-search-paths
(append (package-native-search-paths python)
(standard-search-paths)))
@ -70,15 +120,15 @@ provides a 'setup.py' file as its build system."
`(begin
(use-modules ,@modules)
(python-build #:name ,name
#:source ,(if (and source (derivation-path? source))
(derivation-path->output-path source)
#:source ,(if (derivation? source)
(derivation->output-path source)
source)
#:configure-flags ,configure-flags
#:system ,system
#:test-target "test"
#:tests? ,tests?
#:phases ,phases
#:outputs %outputs
#:python-version ,python-version
#:search-paths ',(map search-path-specification->sexp
(append python-search-paths
search-paths))

4
guix/build/linux-initrd.scm
View File

@ -89,6 +89,10 @@
(device-number 4 n))
(loop (+ 1 n)))))
;; Rendez-vous point for syslogd.
(mknod (scope "dev/log") 'socket #o666 0)
(mknod (scope "dev/kmsg") 'char-special #o600 (device-number 1 11))
;; Other useful nodes.
(mknod (scope "dev/null") 'char-special #o666 (device-number 1 3))
(mknod (scope "dev/zero") 'char-special #o666 (device-number 1 5)))

71
guix/build/python-build-system.scm
View File

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;;
;;; This file is part of GNU Guix.
@ -34,26 +35,49 @@
;;
;; Code:
(define* (install #:key outputs (configure-flags '())
#:allow-other-keys)
"Install a given Python package."
(let ((out (assoc-ref outputs "out")))
(if (file-exists? "setup.py")
(let ((args `("setup.py" "install" ,(string-append "--prefix=" out)
,@configure-flags)))
(format #t "running 'python' with arguments ~s~%" args)
(zero? (apply system* "python" args)))
(error "no setup.py found"))))
(define* (check #:key outputs #:allow-other-keys)
"Run the test suite of a given Python package."
(define (call-setuppy command params)
(if (file-exists? "setup.py")
(let ((args `("setup.py" "check")))
(format #t "running 'python' with arguments ~s~%" args)
(zero? (apply system* "python" args)))
(begin
(format #t "running \"python setup.py\" with command ~s and parameters ~s~%"
command params)
(zero? (apply system* "python" "setup.py" command params)))
(error "no setup.py found")))
(define* (wrap #:key outputs python-version #:allow-other-keys)
(define* (build #:rest empty)
"Build a given Python package."
(call-setuppy "build" '()))
(define* (check #:key tests? test-target #:allow-other-keys)
"Run the test suite of a given Python package."
(if tests?
(call-setuppy test-target '())
#t))
(define (get-python-version python)
(string-take (string-take-right python 5) 3))
(define* (install #:key outputs inputs (configure-flags '())
#:allow-other-keys)
"Install a given Python package."
(let* ((out (assoc-ref outputs "out"))
(params (append (list (string-append "--prefix=" out))
configure-flags))
(python-version (get-python-version (assoc-ref inputs "python")))
(old-path (getenv "PYTHONPATH"))
(add-path (string-append out "/lib/python" python-version
"/site-packages/")))
;; create the module installation directory and add it to PYTHONPATH
;; to make setuptools happy
(mkdir-p add-path)
(setenv "PYTHONPATH"
(string-append (if old-path
(string-append old-path ":")
"")
add-path))
(call-setuppy "install" params)))
(define* (wrap #:key inputs outputs #:allow-other-keys)
(define (list-of-files dir)
(map (cut string-append dir "/" <>)
(or (scandir dir (lambda (f)
@ -69,9 +93,11 @@
outputs))
(let* ((out (assoc-ref outputs "out"))
(python (assoc-ref inputs "python"))
(var `("PYTHONPATH" prefix
,(cons (string-append out "/lib/python"
python-version "/site-packages")
(get-python-version python)
"/site-packages")
(search-path-as-string->list
(or (getenv "PYTHONPATH") ""))))))
(for-each (lambda (dir)
@ -87,11 +113,12 @@
'install 'wrap
wrap
(alist-replace
'check check
(alist-replace 'install install
(alist-delete 'configure
(alist-delete 'build
gnu:%standard-phases))))))
'build build
(alist-replace
'check check
(alist-replace 'install install
(alist-delete 'configure
gnu:%standard-phases))))))
(define* (python-build #:key inputs (phases %standard-phases)
#:allow-other-keys #:rest args)

129
guix/derivations.scm
View File

@ -19,6 +19,7 @@
(define-module (guix derivations)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-26)
#:use-module (rnrs io ports)
#:use-module (rnrs bytevectors)
@ -36,6 +37,7 @@
derivation-system
derivation-builder-arguments
derivation-builder-environment-vars
derivation-file-name
derivation-prerequisites
derivation-prerequisites-to-build
@ -56,6 +58,8 @@
read-derivation
write-derivation
derivation->output-path
derivation->output-paths
derivation-path->output-path
derivation-path->output-paths
derivation
@ -64,14 +68,16 @@
imported-modules
compiled-modules
build-expression->derivation
imported-files))
imported-files)
#:replace (build-derivations))
;;;
;;; Nix derivations, as implemented in Nix's `derivations.cc'.
;;;
(define-record-type <derivation>
(make-derivation outputs inputs sources system builder args env-vars)
(make-derivation outputs inputs sources system builder args env-vars
file-name)
derivation?
(outputs derivation-outputs) ; list of name/<derivation-output> pairs
(inputs derivation-inputs) ; list of <derivation-input>
@ -79,7 +85,8 @@
(system derivation-system) ; string
(builder derivation-builder) ; store path
(args derivation-builder-arguments) ; list of strings
(env-vars derivation-builder-environment-vars)) ; list of name/value pairs
(env-vars derivation-builder-environment-vars) ; list of name/value pairs
(file-name derivation-file-name)) ; the .drv file name
(define-record-type <derivation-output>
(make-derivation-output path hash-algo hash)
@ -94,6 +101,17 @@
(path derivation-input-path) ; store path
(sub-derivations derivation-input-sub-derivations)) ; list of strings
(set-record-type-printer! <derivation>
(lambda (drv port)
(format port "#<derivation ~a => ~a ~a>"
(derivation-file-name drv)
(string-join
(map (match-lambda
((_ . output)
(derivation-output-path output)))
(derivation-outputs drv)))
(number->string (object-address drv) 16))))
(define (fixed-output-derivation? drv)
"Return #t if DRV is a fixed-output derivation, such as the result of a
download with a fixed hash (aka. `fetchurl')."
@ -262,7 +280,8 @@ that second value is the empty list."
(make-input-drvs input-drvs)
input-srcs
system builder args
(fold-right alist-cons '() var value)))
(fold-right alist-cons '() var value)
(port-filename drv-port)))
(_
(error "failed to parse derivation" drv-port result)))))
((? (cut eq? <> comma))
@ -404,25 +423,30 @@ that form."
port)
(display ")" port))))
(define* (derivation->output-path drv #:optional (output "out"))
"Return the store path of its output OUTPUT."
(let ((outputs (derivation-outputs drv)))
(and=> (assoc-ref outputs output) derivation-output-path)))
(define (derivation->output-paths drv)
"Return the list of name/path pairs of the outputs of DRV."
(map (match-lambda
((name . output)
(cons name (derivation-output-path output))))
(derivation-outputs drv)))
(define derivation-path->output-path
;; This procedure is called frequently, so memoize it.
(memoize
(lambda* (path #:optional (output "out"))
"Read the derivation from PATH (`/nix/store/xxx.drv'), and return the store
path of its output OUTPUT."
(let* ((drv (call-with-input-file path read-derivation))
(outputs (derivation-outputs drv)))
(and=> (assoc-ref outputs output) derivation-output-path)))))
(derivation->output-path (call-with-input-file path read-derivation)))))
(define (derivation-path->output-paths path)
"Read the derivation from PATH (`/nix/store/xxx.drv'), and return the
list of name/path pairs of its outputs."
(let* ((drv (call-with-input-file path read-derivation))
(outputs (derivation-outputs drv)))
(map (match-lambda
((name . output)
(cons name (derivation-output-path output))))
outputs)))
(derivation->output-paths (call-with-input-file path read-derivation)))
;;;
@ -470,7 +494,8 @@ in SIZE bytes."
(make-derivation-input hash sub-drvs))))
inputs))
(drv (make-derivation outputs inputs sources
system builder args env-vars)))
system builder args env-vars
#f)))
;; XXX: At this point this remains faster than `port-sha256', because
;; the SHA256 port's `write' method gets called for every single
@ -505,10 +530,10 @@ the derivation called NAME with hash HASH."
(inputs '()) (outputs '("out"))
hash hash-algo hash-mode
references-graphs)
"Build a derivation with the given arguments. Return the resulting
store path and <derivation> object. When HASH, HASH-ALGO, and HASH-MODE
are given, a fixed-output derivation is created---i.e., one whose result is
known in advance, such as a file download.
"Build a derivation with the given arguments, and return the resulting
<derivation> object. When HASH, HASH-ALGO, and HASH-MODE are given, a
fixed-output derivation is created---i.e., one whose result is known in
advance, such as a file download.
When REFERENCES-GRAPHS is true, it must be a list of file name/store path
pairs. In that case, the reference graph of each store path is exported in
@ -545,7 +570,8 @@ the build environment in the corresponding file, in a simple text format."
(or (and=> (assoc-ref outputs name)
derivation-output-path)
value))))
env-vars))))))
env-vars)
#f)))))
(define (user+system-env-vars)
;; Some options are passed to the build daemon via the env. vars of
@ -578,12 +604,26 @@ the build environment in the corresponding file, in a simple text format."
e
outputs)))
(define (set-file-name drv file)
;; Set FILE as the 'file-name' field of DRV.
(match drv
(($ <derivation> outputs inputs sources system builder
args env-vars)
(make-derivation outputs inputs sources system builder
args env-vars file))))
(let* ((outputs (map (lambda (name)
;; Return outputs with an empty path.
(cons name
(make-derivation-output "" hash-algo hash)))
outputs))
(inputs (map (match-lambda
(((? derivation? drv))
(make-derivation-input (derivation-file-name drv)
'("out")))
(((? derivation? drv) sub-drvs ...)
(make-derivation-input (derivation-file-name drv)
sub-drvs))
(((? direct-store-path? input))
(make-derivation-input input '("out")))
(((? direct-store-path? input) sub-drvs ...)
@ -604,17 +644,29 @@ the build environment in the corresponding file, in a simple text format."
(and (not (derivation-path? p))
p)))
inputs)
system builder args env-vars))
system builder args env-vars #f))
(drv (add-output-paths drv-masked)))
;; (write-derivation drv-masked (current-error-port))
;; (newline (current-error-port))
(values (add-text-to-store store (string-append name ".drv")
(call-with-output-string
(cut write-derivation drv <>))
(map derivation-input-path
inputs))
drv)))
(let ((file (add-text-to-store store (string-append name ".drv")
(call-with-output-string
(cut write-derivation drv <>))
(map derivation-input-path
inputs))))
(set-file-name drv file))))
;;;
;;; Store compatibility layer.
;;;
(define (build-derivations store derivations)
"Build DERIVATIONS, a list of <derivation> objects or .drv file names."
(let ((build (@ (guix store) build-derivations)))
(build store (map (match-lambda
((? string? file) file)
((and drv ($ <derivation>))
(derivation-file-name drv)))
derivations))))
;;;
@ -706,7 +758,7 @@ they can refer to each other."
#:system system
#:guile guile
#:module-path module-path))
(module-dir (derivation-path->output-path module-drv))
(module-dir (derivation->output-path module-drv))
(files (map (lambda (m)
(let ((f (string-join (map symbol->string m)
"/")))
@ -770,7 +822,7 @@ See the `derivation' procedure for the meaning of REFERENCES-GRAPHS."
(or guile-for-build (%guile-for-build)))
(define guile
(string-append (derivation-path->output-path guile-drv)
(string-append (derivation->output-path guile-drv)
"/bin/guile"))
(define module-form?
@ -782,6 +834,8 @@ See the `derivation' procedure for the meaning of REFERENCES-GRAPHS."
;; When passed an input that is a source, return its path; otherwise
;; return #f.
(match-lambda
((_ (? derivation?) _ ...)
#f)
((_ path _ ...)
(and (not (derivation-path? path))
path))))
@ -806,10 +860,13 @@ See the `derivation' procedure for the meaning of REFERENCES-GRAPHS."
(() "out")
((x) x))))
(cons name
(if (derivation-path? drv)
(derivation-path->output-path drv
sub)
drv)))))
(cond
((derivation? drv)
(derivation->output-path drv sub))
((derivation-path? drv)
(derivation-path->output-path drv
sub))
(else drv))))))
inputs))
,@(if (null? modules)
@ -854,13 +911,13 @@ See the `derivation' procedure for the meaning of REFERENCES-GRAPHS."
#:guile guile-drv
#:system system)))
(mod-dir (and mod-drv
(derivation-path->output-path mod-drv)))
(derivation->output-path mod-drv)))
(go-drv (and (pair? modules)
(compiled-modules store modules
#:guile guile-drv
#:system system)))
(go-dir (and go-drv
(derivation-path->output-path go-drv))))
(derivation->output-path go-drv))))
(derivation store name guile
`("--no-auto-compile"
,@(if mod-dir `("-L" ,mod-dir) '())

32
guix/download.scm
View File

@ -25,7 +25,6 @@
#:use-module ((guix build download) #:renamer (symbol-prefix-proc 'build:))
#:use-module (guix utils)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:export (%mirrors
url-fetch
@ -212,27 +211,22 @@ must be a list of symbol/URL-list pairs."
((url ...)
(any https? url)))))
(let*-values (((gnutls-drv-path gnutls-drv)
(if need-gnutls?
(gnutls-derivation store system)
(values #f #f)))
((gnutls)
(and gnutls-drv
(derivation-output-path
(assoc-ref (derivation-outputs gnutls-drv)
"out"))))
((env-vars)
(if gnutls
(let ((dir (string-append gnutls "/share/guile/site")))
;; XXX: `GUILE_LOAD_COMPILED_PATH' is overridden
;; by `build-expression->derivation', so we can't
;; set it here.
`(("GUILE_LOAD_PATH" . ,dir)))
'())))
(let* ((gnutls-drv (if need-gnutls?
(gnutls-derivation store system)
(values #f #f)))
(gnutls (and gnutls-drv
(derivation->output-path gnutls-drv "out")))
(env-vars (if gnutls
(let ((dir (string-append gnutls "/share/guile/site")))
;; XXX: `GUILE_LOAD_COMPILED_PATH' is overridden
;; by `build-expression->derivation', so we can't
;; set it here.
`(("GUILE_LOAD_PATH" . ,dir)))
'())))
(build-expression->derivation store (or name file-name) system
builder
(if gnutls-drv
`(("gnutls" ,gnutls-drv-path))
`(("gnutls" ,gnutls-drv))
'())
#:hash-algo hash-algo
#:hash hash

9
guix/nar.scm
View File

@ -76,10 +76,11 @@
;; avoid stat'ing like crazy.
(with-fluids ((%file-port-name-canonicalization #f))
(let ((port (open-file file "rb")))
(catch #t (cut proc port)
(lambda args
(close-port port)
(apply throw args))))))
(dynamic-wind
(const #t)
(cut proc port)
(lambda ()
(close-port port))))))
(write-string "contents" p)
(write-long-long size p)

11
guix/packages.scm
View File

@ -26,7 +26,6 @@
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
@ -370,8 +369,8 @@ information in exceptions."
(define* (package-derivation store package
#:optional (system (%current-system)))
"Return the derivation path and corresponding <derivation> object of
PACKAGE for SYSTEM."
"Return the <derivation> object of PACKAGE for SYSTEM."
;; Compute the derivation and cache the result. Caching is important
;; because some derivations, such as the implicit inputs of the GNU build
;; system, will be queried many, many times in a row.
@ -468,7 +467,5 @@ system identifying string)."
"Return the output path of PACKAGE's OUTPUT for SYSTEM---where OUTPUT is the
symbolic output name, such as \"out\". Note that this procedure calls
`package-derivation', which is costly."
(let-values (((_ drv)
(package-derivation store package system)))
(derivation-output-path
(assoc-ref (derivation-outputs drv) output))))
(let ((drv (package-derivation store package system)))
(derivation->output-path drv output)))

23
guix/scripts/build.scm
View File

@ -250,7 +250,7 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
(derivations-from-package-expressions
str package->derivation sys src?))
(('argument . (? derivation-path? drv))
drv)
(call-with-input-file drv read-derivation))
(('argument . (? string? x))
(let ((p (find-package x)))
(if src?
@ -280,24 +280,23 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
(if (assoc-ref opts 'derivations-only?)
(begin
(format #t "~{~a~%~}" drv)
(format #t "~{~a~%~}" (map derivation-file-name drv))
(for-each (cut register-root <> <>)
(map list drv) roots))
(map (compose list derivation-file-name) drv)
roots))
(or (assoc-ref opts 'dry-run?)
(and (build-derivations (%store) drv)
(for-each (lambda (d)
(let ((drv (call-with-input-file d
read-derivation)))
(format #t "~{~a~%~}"
(map (match-lambda
((out-name . out)
(derivation-path->output-path
d out-name)))
(derivation-outputs drv)))))
(format #t "~{~a~%~}"
(map (match-lambda
((out-name . out)
(derivation->output-path
d out-name)))
(derivation-outputs d))))
drv)
(for-each (cut register-root <> <>)
(map (lambda (drv)
(map cdr
(derivation-path->output-paths drv)))
(derivation->output-paths drv)))
drv)
roots)))))))))

172
guix/scripts/package.scm
View File

@ -34,6 +34,7 @@
#:use-module (ice-9 vlist)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-37)
@ -95,8 +96,8 @@
(make-regexp (string-append "^" (regexp-quote (basename profile))
"-([0-9]+)")))
(define (profile-numbers profile)
"Return the list of generation numbers of PROFILE, or '(0) if no
(define (generation-numbers profile)
"Return the sorted list of generation numbers of PROFILE, or '(0) if no
former profiles were found."
(define* (scandir name #:optional (select? (const #t))
(entry<? (@ (ice-9 i18n) string-locale<?)))
@ -139,12 +140,13 @@ former profiles were found."
(() ; no profiles
'(0))
((profiles ...) ; former profiles around
(map (compose string->number
(cut match:substring <> 1)
(cute regexp-exec (profile-regexp profile) <>))
profiles))))
(sort (map (compose string->number
(cut match:substring <> 1)
(cute regexp-exec (profile-regexp profile) <>))
profiles)
<))))
(define (previous-profile-number profile number)
(define (previous-generation-number profile number)
"Return the number of the generation before generation NUMBER of
PROFILE, or 0 if none exists. It could be NUMBER - 1, but it's not the
case when generations have been deleted (there are \"holes\")."
@ -153,7 +155,7 @@ case when generations have been deleted (there are \"holes\")."
candidate
highest))
0
(profile-numbers profile)))
(generation-numbers profile)))
(define (profile-derivation store packages)
"Return a derivation that builds a profile (a user environment) with
@ -205,7 +207,7 @@ all of PACKAGES, a list of name/version/output/path/deps tuples."
packages)
#:modules '((guix build union))))
(define (profile-number profile)
(define (generation-number profile)
"Return PROFILE's number or 0. An absolute file name must be used."
(or (and=> (false-if-exception (regexp-exec (profile-regexp profile)
(basename (readlink profile))))
@ -214,17 +216,17 @@ all of PACKAGES, a list of name/version/output/path/deps tuples."
(define (roll-back profile)
"Roll back to the previous generation of PROFILE."
(let* ((number (profile-number profile))
(previous-number (previous-profile-number profile number))
(previous-profile (format #f "~a-~a-link"
profile previous-number))
(manifest (string-append previous-profile "/manifest")))
(let* ((number (generation-number profile))
(previous-number (previous-generation-number profile number))
(previous-generation (format #f "~a-~a-link"
profile previous-number))
(manifest (string-append previous-generation "/manifest")))
(define (switch-link)
;; Atomically switch PROFILE to the previous profile.
;; Atomically switch PROFILE to the previous generation.
(format #t (_ "switching from generation ~a to ~a~%")
number previous-number)
(switch-symlinks profile previous-profile))
(switch-symlinks profile previous-generation))
(cond ((not (file-exists? profile)) ; invalid profile
(leave (_ "profile `~a' does not exist~%")
@ -233,19 +235,84 @@ all of PACKAGES, a list of name/version/output/path/deps tuples."
(format (current-error-port)
(_ "nothing to do: already at the empty profile~%")))
((or (zero? previous-number) ; going to emptiness
(not (file-exists? previous-profile)))
(let*-values (((drv-path drv)
(profile-derivation (%store) '()))
((prof)
(derivation-output-path
(assoc-ref (derivation-outputs drv) "out"))))
(when (not (build-derivations (%store) (list drv-path)))
(not (file-exists? previous-generation)))
(let* ((drv (profile-derivation (%store) '()))
(prof (derivation->output-path drv "out")))
(when (not (build-derivations (%store) (list drv)))
(leave (_ "failed to build the empty profile~%")))
(switch-symlinks previous-profile prof)
(switch-symlinks previous-generation prof)
(switch-link)))
(else (switch-link))))) ; anything else
(define (generation-time profile number)
"Return the creation time of a generation in the UTC format."
(make-time time-utc 0
(stat:ctime (stat (format #f "~a-~a-link" profile number)))))
(define* (matching-generations str #:optional (profile %current-profile))
"Return the list of available generations matching a pattern in STR. See
'string->generations' and 'string->duration' for the list of valid patterns."
(define (valid-generations lst)
(define (valid-generation? n)
(any (cut = n <>) (generation-numbers profile)))
(fold-right (lambda (x acc)
(if (valid-generation? x)
(cons x acc)
acc))
'()
lst))
(define (filter-generations generations)
(match generations
(() '())
(('>= n)
(drop-while (cut > n <>)
(generation-numbers profile)))
(('<= n)
(valid-generations (iota n 1)))
((lst ..1)
(valid-generations lst))
(_ #f)))
(define (filter-by-duration duration)
(define (time-at-midnight time)
;; Return TIME at midnight by setting nanoseconds, seconds, minutes, and
;; hours to zeros.
(let ((d (time-utc->date time)))
(date->time-utc
(make-date 0 0 0 0
(date-day d) (date-month d)
(date-year d) (date-zone-offset d)))))
(define generation-ctime-alist
(map (lambda (number)
(cons number
(time-second
(time-at-midnight
(generation-time profile number)))))
(generation-numbers profile)))
(match duration
(#f #f)
(res
(let ((s (time-second
(subtract-duration (time-at-midnight (current-time))
duration))))
(delete #f (map (lambda (x)
(and (<= s (cdr x))
(first x)))
generation-ctime-alist))))))
(cond ((string->generations str)
=>
filter-generations)
((string->duration str)
=>
filter-by-duration)
(else #f)))
(define (find-packages-by-description rx)
"Search in SYNOPSIS and DESCRIPTION using RX. Return a list of
matching packages."
@ -441,6 +508,9 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
--roll-back roll back to the previous generation"))
(display (_ "
--search-paths display needed environment variable definitions"))
(display (_ "
-l, --list-generations[=PATTERN]
list generations matching PATTERN"))
(newline)
(display (_ "
-p, --profile=PROFILE use PROFILE instead of the user's default profile"))
@ -500,6 +570,10 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
(option '("roll-back") #f #f
(lambda (opt name arg result)
(alist-cons 'roll-back? #t result)))
(option '(#\l "list-generations") #f #t
(lambda (opt name arg result)
(cons `(query list-generations ,(or arg ""))
result)))
(option '("search-paths") #f #f
(lambda (opt name arg result)
(cons `(query search-paths) result)))
@ -558,7 +632,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
(define (guile-missing?)
;; Return #t if %GUILE-FOR-BUILD is not available yet.
(let ((out (derivation-path->output-path (%guile-for-build))))
(let ((out (derivation->output-path (%guile-for-build))))
(not (valid-path? (%store) out))))
(define newest-available-packages
@ -617,7 +691,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
(case (version-compare candidate-version current-version)
((>) #t)
((<) #f)
((=) (let ((candidate-path (derivation-path->output-path
((=) (let ((candidate-path (derivation->output-path
(package-derivation (%store) pkg))))
(not (string=? current-path candidate-path))))))
(#f #f)))
@ -808,7 +882,7 @@ more information.~%"))
(match tuple
((name version sub-drv _ (deps ...))
(let ((output-path
(derivation-path->output-path
(derivation->output-path
drv sub-drv)))
`(,name ,version ,sub-drv ,output-path
,(canonicalize-deps deps))))))
@ -841,12 +915,12 @@ more information.~%"))
(or dry-run?
(and (build-derivations (%store) drv)
(let* ((prof-drv (profile-derivation (%store) packages))
(prof (derivation-path->output-path prof-drv))
(prof (derivation->output-path prof-drv))
(old-drv (profile-derivation
(%store) (manifest-packages
(profile-manifest profile))))
(old-prof (derivation-path->output-path old-drv))
(number (profile-number profile))
(old-prof (derivation->output-path old-drv))
(number (generation-number profile))
;; Always use NUMBER + 1 for the new profile,
;; possibly overwriting a "previous future
@ -879,6 +953,40 @@ more information.~%"))
;; actually processed, #f otherwise.
(let ((profile (assoc-ref opts 'profile)))
(match (assoc-ref opts 'query)
(('list-generations pattern)
(define (list-generation number)
(begin
(format #t (_ "Generation ~a\t~a~%") number
(date->string
(time-utc->date
(generation-time profile number))
"~b ~d ~Y ~T"))
(for-each (match-lambda
((name version output location _)
(format #t " ~a\t~a\t~a\t~a~%"
name version output location)))
;; Show most recently installed packages last.
(reverse
(manifest-packages
(profile-manifest
(format #f "~a-~a-link" profile number)))))
(newline)))
(cond ((not (file-exists? profile)) ; XXX: race condition
(leave (_ "profile '~a' does not exist~%")
profile))
((string-null? pattern)
(for-each list-generation
(generation-numbers profile)))
((matching-generations pattern profile)
=>
(cut for-each list-generation <>))
(else
(leave (_ "invalid syntax: ~a~%")
pattern)))
#t)
(('list-installed regexp)
(let* ((regexp (and regexp (make-regexp regexp)))
(manifest (profile-manifest profile))
@ -889,7 +997,9 @@ more information.~%"))
(regexp-exec regexp name))
(format #t "~a\t~a\t~a\t~a~%"
name (or version "?") output path))))
installed)
;; Show most recently installed packages last.
(reverse installed))
#t))
(('list-available regexp)

11
guix/scripts/pull.scm
View File

@ -29,7 +29,6 @@
#:use-module (gnu packages compression)
#:use-module (gnu packages gnupg)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-37)
#:export (guix-pull))
@ -198,13 +197,9 @@ Download and deploy the latest version of Guix.\n"))
(if (assoc-ref opts 'verbose?)
(current-error-port)
(%make-void-port "w"))))
(let*-values (((config-dir)
(config-directory))
((source drv)
(unpack store tarball))
((source-dir)
(derivation-output-path
(assoc-ref (derivation-outputs drv) "out"))))
(let* ((config-dir (config-directory))
(source (unpack store tarball))
(source-dir (derivation->output-path source)))
(if (show-what-to-build store (list source))
(if (build-derivations store (list source))
(let ((latest (string-append config-dir "/latest")))

30
guix/scripts/substitute-binary.scm
View File

@ -444,6 +444,30 @@ PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by
(leave (_ "host name lookup error: ~a~%")
(gai-strerror error)))))))
;;;
;;; Help.
;;;
(define (show-help)
(display (_ "Usage: guix substitute-binary [OPTION]...
Internal tool to substitute a pre-built binary to a local build.\n"))
(display (_ "
--query report on the availability of substitutes for the
store file names passed on the standard input"))
(display (_ "
--substitute STORE-FILE DESTINATION
download STORE-FILE and store it as a Nar in file
DESTINATION"))
(newline)
(display (_ "
-h, --help display this help and exit"))
(display (_ "
-V, --version display version information and exit"))
(newline)
(show-bug-report-information))
;;;
;;; Entry point.
@ -536,7 +560,11 @@ PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by
(restore-file input destination)
(every (compose zero? cdr waitpid) pids))))
(("--version")
(show-version-and-exit "guix substitute-binary")))))
(show-version-and-exit "guix substitute-binary"))
(("--help")
(show-help))
(opts
(leave (_ "~a: unrecognized options~%") opts)))))
;;; Local Variables:

2
guix/store.scm
View File

@ -452,7 +452,7 @@ encoding conversion errors."
(string-list references))
#f
store-path)))
(lambda (server name text references)
(lambda* (server name text #:optional (references '()))
"Add TEXT under file NAME in the store, and return its store path.
REFERENCES is the list of store paths referred to by the resulting store
path."

102
guix/ui.scm
View File

@ -28,12 +28,14 @@
#:use-module ((guix licenses) #:select (license? license-name))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-37)
#:autoload (ice-9 ftw) (scandir)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:use-module (ice-9 regex)
#:export (_
N_
leave
@ -50,6 +52,8 @@
fill-paragraph
string->recutils
package->recutils
string->generations
string->duration
args-fold*
run-guix-command
program-name
@ -210,27 +214,27 @@ derivations listed in DRV. Return #t if there's something to build, #f
otherwise. When USE-SUBSTITUTES?, check and report what is prerequisites are
available for download."
(let*-values (((build download)
(fold2 (lambda (drv-path build download)
(let ((drv (call-with-input-file drv-path
read-derivation)))
(let-values (((b d)
(derivation-prerequisites-to-build
store drv
#:use-substitutes?
use-substitutes?)))
(values (append b build)
(append d download)))))
(fold2 (lambda (drv build download)
(let-values (((b d)
(derivation-prerequisites-to-build
store drv
#:use-substitutes?
use-substitutes?)))
(values (append b build)
(append d download))))
'() '()
drv))
((build) ; add the DRV themselves
(delete-duplicates
(append (remove (compose (lambda (out)
(or (valid-path? store out)
(and use-substitutes?
(has-substitutes? store
out))))
derivation-path->output-path)
drv)
(append (map derivation-file-name
(remove (lambda (drv)
(let ((out (derivation->output-path
drv)))
(or (valid-path? store out)
(and use-substitutes?
(has-substitutes? store
out)))))
drv))
(map derivation-input-path build))))
((download) ; add the references of DOWNLOAD
(if use-substitutes?
@ -404,6 +408,70 @@ WIDTH columns."
(and=> (package-description p) description->recutils))
(newline port))
(define (string->generations str)
"Return the list of generations matching a pattern in STR. This function
accepts the following patterns: \"1\", \"1,2,3\", \"1..9\", \"1..\", \"..9\"."
(define (maybe-integer)
(let ((x (string->number str)))
(and (integer? x)
x)))
(define (maybe-comma-separated-integers)
(let ((lst (delete-duplicates
(map string->number
(string-split str #\,)))))
(and (every integer? lst)
lst)))
(cond ((maybe-integer)
=>
list)
((maybe-comma-separated-integers)
=>
identity)
((string-match "^([0-9]+)\\.\\.([0-9]+)$" str)
=>
(lambda (match)
(let ((s (string->number (match:substring match 1)))
(e (string->number (match:substring match 2))))
(and (every integer? (list s e))
(<= s e)
(iota (1+ (- e s)) s)))))
((string-match "^([0-9]+)\\.\\.$" str)
=>
(lambda (match)
(let ((s (string->number (match:substring match 1))))
(and (integer? s)
`(>= ,s)))))
((string-match "^\\.\\.([0-9]+)$" str)
=>
(lambda (match)
(let ((e (string->number (match:substring match 1))))
(and (integer? e)
`(<= ,e)))))
(else #f)))
(define (string->duration str)
"Return the duration matching a pattern in STR. This function accepts the
following patterns: \"1d\", \"1w\", \"1m\"."
(define (hours->duration hours match)
(make-time time-duration 0
(* 3600 hours (string->number (match:substring match 1)))))
(cond ((string-match "^([0-9]+)d$" str)
=>
(lambda (match)
(hours->duration 24 match)))
((string-match "^([0-9]+)w$" str)
=>
(lambda (match)
(hours->duration (* 24 7) match)))
((string-match "^([0-9]+)m$" str)
=>
(lambda (match)
(hours->duration (* 24 30) match)))
(else #f)))
(define (args-fold* options unrecognized-option-proc operand-proc . seeds)
"A wrapper on top of `args-fold' that does proper user-facing error
reporting."

168
nix/guix-register/guix-register.cc 100644
View File

@ -0,0 +1,168 @@
/* GNU Guix --- Functional package management for GNU
Copyright (C) 2013 Ludovic Courtès <ludo@gnu.org>
Copyright (C) 2007, 2008, 2009, 2010, 2011, 2012,
2013 Eelco Dolstra <eelco.dolstra@logicblox.com>
This file is part of GNU Guix.
GNU 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.
GNU 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 GNU Guix. If not, see <http://www.gnu.org/licenses/>. */
/* This file derives from the implementation of 'nix-store
--register-validity', by Eelco Dolstra, as found in the Nix package
manager's src/nix-store/nix-store.cc. */
#include <config.h>
#include <globals.hh>
#include <local-store.hh>
#include <iostream>
#include <fstream>
#include <cstdlib>
#include <cstdio>
#include <argp.h>
using namespace nix;
/* Input stream where we read closure descriptions. */
static std::istream *input = &std::cin;
/* Command-line options. */
const char *argp_program_version =
"guix-register (" PACKAGE_NAME ") " PACKAGE_VERSION;
const char *argp_program_bug_address = PACKAGE_BUGREPORT;
static char doc[] =
"guix-register -- register a closure as valid in a store\
\v\
This program is used internally when populating a store with data \
from an existing store. It updates the new store's database with \
information about which store files are valid, and what their \
references are.";
static const struct argp_option options[] =
{
{ "prefix", 'p', "DIRECTORY", 0,
"Open the store that lies under DIRECTORY" },
{ 0, 0, 0, 0, 0 }
};
/* Parse a single option. */
static error_t
parse_opt (int key, char *arg, struct argp_state *state)
{
switch (key)
{
case 'p':
{
string prefix = canonPath (arg);
settings.nixStore = prefix + NIX_STORE_DIR;
settings.nixDataDir = prefix + NIX_DATA_DIR;
settings.nixLogDir = prefix + NIX_LOG_DIR;
settings.nixStateDir = prefix + NIX_STATE_DIR;
settings.nixDBPath = settings.nixStateDir + "/db";
break;
}
case ARGP_KEY_ARG:
{
std::ifstream *file;
if (state->arg_num >= 2)
/* Too many arguments. */
argp_usage (state);
file = new std::ifstream ();
file->open (arg);
input = file;
}
break;
default:
return (error_t) ARGP_ERR_UNKNOWN;
}
return (error_t) 0;
}
/* Argument parsing. */
static struct argp argp = { options, parse_opt, 0, doc };
/* Read from INPUT the description of a closure, and register it as valid in
STORE. The expected format on INPUT is that used by #:references-graphs:
FILE
DERIVER
NUMBER-OF-REFERENCES
REF1
...
REFN
This is really meant as an internal format. */
static void
register_validity (LocalStore *store, std::istream &input,
bool reregister = true, bool hashGiven = false,
bool canonicalise = true)
{
ValidPathInfos infos;
while (1)
{
ValidPathInfo info = decodeValidPathInfo (input, hashGiven);
if (info.path == "")
break;
if (!store->isValidPath (info.path) || reregister)
{
/* !!! races */
if (canonicalise)
canonicalisePathMetaData (info.path, -1);
if (!hashGiven)
{
HashResult hash = hashPath (htSHA256, info.path);
info.hash = hash.first;
info.narSize = hash.second;
}
infos.push_back (info);
}
}
store->registerValidPaths (infos);
}
int
main (int argc, char *argv[])
{
try
{
argp_parse (&argp, argc, argv, 0, 0, 0);
LocalStore store;
register_validity (&store, *input);
}
catch (std::exception &e)
{
fprintf (stderr, "error: %s\n", e.what ());
return EXIT_FAILURE;
}
return EXIT_SUCCESS;
}

6
nix/libutil/gcrypt-hash.cc
View File

@ -1,5 +1,5 @@
/* GNU Guix --- Functional package management for GNU
Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org>
Copyright (C) 2012, 2013 Ludovic Courtès <ludo@gnu.org>
This file is part of GNU Guix.
@ -24,7 +24,7 @@
extern "C" {
void
guix_hash_init (struct guix_hash_context *ctx, gcry_md_algo_t algo)
guix_hash_init (struct guix_hash_context *ctx, int algo)
{
gcry_error_t err;
@ -40,7 +40,7 @@ guix_hash_update (struct guix_hash_context *ctx, const void *buffer, size_t len)
void
guix_hash_final (void *resbuf, struct guix_hash_context *ctx,
gcry_md_algo_t algo)
int algo)
{
memcpy (resbuf, gcry_md_read (ctx->md_handle, algo),
gcry_md_get_algo_dlen (algo));

6
nix/libutil/gcrypt-hash.hh
View File

@ -1,5 +1,5 @@
/* GNU Guix --- Functional package management for GNU
Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org>
Copyright (C) 2012, 2013 Ludovic Courtès <ludo@gnu.org>
This file is part of GNU Guix.
@ -30,10 +30,10 @@ struct guix_hash_context
gcry_md_hd_t md_handle;
};
extern void guix_hash_init (struct guix_hash_context *ctx, gcry_md_algo_t algo);
extern void guix_hash_init (struct guix_hash_context *ctx, int algo);
extern void guix_hash_update (struct guix_hash_context *ctx, const void *buffer,
size_t len);
extern void guix_hash_final (void *resbuf, struct guix_hash_context *ctx,
gcry_md_algo_t algo);
int algo);
}

7
test-env.in
View File

@ -69,5 +69,12 @@ then
trap "kill $daemon_pid ; rm -rf $NIX_STATE_DIR" EXIT
fi
storedir="@storedir@"
prefix="@prefix@"
datarootdir="@datarootdir@"
datadir="@datadir@"
localstatedir="@localstatedir@"
export storedir prefix datarootdir datadir localstatedir
"@abs_top_builddir@/pre-inst-env" "$@"
exit $?

8
tests/builders.scm
View File

@ -70,10 +70,10 @@
"ftp://ftp.gnu.org/gnu/hello/hello-2.8.tar.gz"))
(hash (nix-base32-string->bytevector
"0wqd8sjmxfskrflaxywc7gqw7sfawrfvdxd9skxawzfgyy0pzdz6"))
(drv-path (url-fetch %store url 'sha256 hash
(drv (url-fetch %store url 'sha256 hash
#:guile %bootstrap-guile))
(out-path (derivation-path->output-path drv-path)))
(and (build-derivations %store (list drv-path))
(out-path (derivation->output-path drv)))
(and (build-derivations %store (list drv))
(file-exists? out-path)
(valid-path? %store out-path))))
@ -93,7 +93,7 @@
#:implicit-inputs? #f
#:guile %bootstrap-guile
#:search-paths %bootstrap-search-paths))
(out (derivation-path->output-path build)))
(out (derivation->output-path build)))
(and (build-derivations %store (list (pk 'hello-drv build)))
(valid-path? %store out)
(file-exists? (string-append out "/bin/hello")))))

218
tests/derivations.scm
View File

@ -110,29 +110,26 @@
(let* ((builder (add-text-to-store %store "my-builder.sh"
"echo hello, world\n"
'()))
(drv-path (derivation %store "foo"
(drv (derivation %store "foo"
%bash `("-e" ,builder)
#:env-vars '(("HOME" . "/homeless")))))
(and (store-path? drv-path)
(valid-path? %store drv-path))))
(and (store-path? (derivation-file-name drv))
(valid-path? %store (derivation-file-name drv)))))
(test-assert "build derivation with 1 source"
(let*-values (((builder)
(add-text-to-store %store "my-builder.sh"
"echo hello, world > \"$out\"\n"
'()))
((drv-path drv)
(derivation %store "foo"
%bash `(,builder)
#:env-vars '(("HOME" . "/homeless")
("zzz" . "Z!")
("AAA" . "A!"))
#:inputs `((,builder))))
((succeeded?)
(build-derivations %store (list drv-path))))
(let* ((builder (add-text-to-store %store "my-builder.sh"
"echo hello, world > \"$out\"\n"
'()))
(drv (derivation %store "foo"
%bash `(,builder)
#:env-vars '(("HOME" . "/homeless")
("zzz" . "Z!")
("AAA" . "A!"))
#:inputs `((,builder))))
(succeeded?
(build-derivations %store (list drv))))
(and succeeded?
(let ((path (derivation-output-path
(assoc-ref (derivation-outputs drv) "out"))))
(let ((path (derivation->output-path drv)))
(and (valid-path? %store path)
(string=? (call-with-input-file path read-line)
"hello, world"))))))
@ -145,7 +142,7 @@
(input (search-path %load-path "ice-9/boot-9.scm"))
(input* (add-to-store %store (basename input)
#t "sha256" input))
(drv-path (derivation %store "derivation-with-input-file"
(drv (derivation %store "derivation-with-input-file"
%bash `(,builder)
;; Cheat to pass the actual file name to the
@ -154,22 +151,22 @@
#:inputs `((,builder)
(,input))))) ; ← local file name
(and (build-derivations %store (list drv-path))
(and (build-derivations %store (list drv))
;; Note: we can't compare the files because the above trick alters
;; the contents.
(valid-path? %store (derivation-path->output-path drv-path)))))
(valid-path? %store (derivation->output-path drv)))))
(test-assert "fixed-output derivation"
(let* ((builder (add-text-to-store %store "my-fixed-builder.sh"
"echo -n hello > $out" '()))
(hash (sha256 (string->utf8 "hello")))
(drv-path (derivation %store "fixed"
(drv (derivation %store "fixed"
%bash `(,builder)
#:inputs `((,builder)) ; optional
#:hash hash #:hash-algo 'sha256))
(succeeded? (build-derivations %store (list drv-path))))
(succeeded? (build-derivations %store (list drv))))
(and succeeded?
(let ((p (derivation-path->output-path drv-path)))
(let ((p (derivation->output-path drv)))
(and (equal? (string->utf8 "hello")
(call-with-input-file p get-bytevector-all))
(bytevector? (query-path-hash %store p)))))))
@ -180,17 +177,16 @@
(builder2 (add-text-to-store %store "fixed-builder2.sh"
"echo hey; echo -n hello > $out" '()))
(hash (sha256 (string->utf8 "hello")))
(drv-path1 (derivation %store "fixed"
(drv1 (derivation %store "fixed"
%bash `(,builder1)
#:hash hash #:hash-algo 'sha256))
(drv-path2 (derivation %store "fixed"
(drv2 (derivation %store "fixed"
%bash `(,builder2)
#:hash hash #:hash-algo 'sha256))
(succeeded? (build-derivations %store
(list drv-path1 drv-path2))))
(succeeded? (build-derivations %store (list drv1 drv2))))
(and succeeded?
(equal? (derivation-path->output-path drv-path1)
(derivation-path->output-path drv-path2)))))
(equal? (derivation->output-path drv1)
(derivation->output-path drv2)))))
(test-assert "derivation with a fixed-output input"
;; A derivation D using a fixed-output derivation F doesn't has the same
@ -207,7 +203,7 @@
(fixed2 (derivation %store "fixed"
%bash `(,builder2)
#:hash hash #:hash-algo 'sha256))
(fixed-out (derivation-path->output-path fixed1))
(fixed-out (derivation->output-path fixed1))
(builder3 (add-text-to-store
%store "final-builder.sh"
;; Use Bash hackery to avoid Coreutils.
@ -223,26 +219,26 @@
(succeeded? (build-derivations %store
(list final1 final2))))
(and succeeded?
(equal? (derivation-path->output-path final1)
(derivation-path->output-path final2)))))
(equal? (derivation->output-path final1)
(derivation->output-path final2)))))
(test-assert "multiple-output derivation"
(let* ((builder (add-text-to-store %store "my-fixed-builder.sh"
"echo one > $out ; echo two > $second"
'()))
(drv-path (derivation %store "fixed"
(drv (derivation %store "fixed"
%bash `(,builder)
#:env-vars '(("HOME" . "/homeless")
("zzz" . "Z!")
("AAA" . "A!"))
#:inputs `((,builder))
#:outputs '("out" "second")))
(succeeded? (build-derivations %store (list drv-path))))
(succeeded? (build-derivations %store (list drv))))
(and succeeded?
(let ((one (derivation-path->output-path drv-path "out"))
(two (derivation-path->output-path drv-path "second")))
(let ((one (derivation->output-path drv "out"))
(two (derivation->output-path drv "second")))
(and (lset= equal?
(derivation-path->output-paths drv-path)
(derivation->output-paths drv)
`(("out" . ,one) ("second" . ,two)))
(eq? 'one (call-with-input-file one read))
(eq? 'two (call-with-input-file two read)))))))
@ -253,14 +249,14 @@
(let* ((builder (add-text-to-store %store "my-fixed-builder.sh"
"echo one > $out ; echo two > $AAA"
'()))
(drv-path (derivation %store "fixed"
(drv (derivation %store "fixed"
%bash `(,builder)
#:inputs `((,builder))
#:outputs '("out" "AAA")))
(succeeded? (build-derivations %store (list drv-path))))
(succeeded? (build-derivations %store (list drv))))
(and succeeded?
(let ((one (derivation-path->output-path drv-path "out"))
(two (derivation-path->output-path drv-path "AAA")))
(let ((one (derivation->output-path drv "out"))
(two (derivation->output-path drv "AAA")))
(and (eq? 'one (call-with-input-file one read))
(eq? 'two (call-with-input-file two read)))))))
@ -282,17 +278,17 @@
(udrv (derivation %store "multiple-output-user"
%bash `(,builder2)
#:env-vars `(("one"
. ,(derivation-path->output-path
. ,(derivation->output-path
mdrv "out"))
("two"
. ,(derivation-path->output-path
. ,(derivation->output-path
mdrv "two")))
#:inputs `((,builder2)
;; two occurrences of MDRV:
(,mdrv)
(,mdrv "two")))))
(and (build-derivations %store (list (pk 'udrv udrv)))
(let ((p (derivation-path->output-path udrv)))
(let ((p (derivation->output-path udrv)))
(and (valid-path? %store p)
(equal? '(one two) (call-with-input-file p read)))))))
@ -317,7 +313,7 @@
("input1" . ,input1)
("input2" . ,input2))
#:inputs `((,%bash) (,builder))))
(out (derivation-path->output-path drv)))
(out (derivation->output-path drv)))
(define (deps path . deps)
(let ((count (length deps)))
(string-append path "\n\n" (number->string count) "\n"
@ -360,31 +356,30 @@
(add-text-to-store %store "build-with-coreutils.sh"
"echo $PATH ; mkdir --version ; mkdir $out ; touch $out/good"
'()))
(drv-path
(drv
(derivation %store "foo"
%bash `(,builder)
#:env-vars `(("PATH" .
,(string-append
(derivation-path->output-path %coreutils)
(derivation->output-path %coreutils)
"/bin")))
#:inputs `((,builder)
(,%coreutils))))
(succeeded?
(build-derivations %store (list drv-path))))
(build-derivations %store (list drv))))
(and succeeded?
(let ((p (derivation-path->output-path drv-path)))
(let ((p (derivation->output-path drv)))
(and (valid-path? %store p)
(file-exists? (string-append p "/good")))))))
(test-skip (if (%guile-for-build) 0 8))
(test-assert "build-expression->derivation and derivation-prerequisites"
(let-values (((drv-path drv)
(build-expression->derivation %store "fail" (%current-system)
#f '())))
(let ((drv (build-expression->derivation %store "fail" (%current-system)
#f '())))
(any (match-lambda
(($ <derivation-input> path)
(string=? path (%guile-for-build))))
(string=? path (derivation-file-name (%guile-for-build)))))
(derivation-prerequisites drv))))
(test-assert "build-expression->derivation without inputs"
@ -393,11 +388,11 @@
(call-with-output-file (string-append %output "/test")
(lambda (p)
(display '(hello guix) p)))))
(drv-path (build-expression->derivation %store "goo" (%current-system)
(drv (build-expression->derivation %store "goo" (%current-system)
builder '()))
(succeeded? (build-derivations %store (list drv-path))))
(succeeded? (build-derivations %store (list drv))))
(and succeeded?
(let ((p (derivation-path->output-path drv-path)))
(let ((p (derivation->output-path drv)))
(equal? '(hello guix)
(call-with-input-file (string-append p "/test") read))))))
@ -406,43 +401,35 @@
(set-build-options s #:max-silent-time 1)
s))
(builder '(sleep 100))
(drv-path (build-expression->derivation %store "silent"
(drv (build-expression->derivation %store "silent"
(%current-system)
builder '()))
(out-path (derivation-path->output-path drv-path)))
(out-path (derivation->output-path drv)))
(guard (c ((nix-protocol-error? c)
(and (string-contains (nix-protocol-error-message c)
"failed")
(not (valid-path? store out-path)))))
(build-derivations %store (list drv-path)))))
(build-derivations %store (list drv)))))
(test-assert "build-expression->derivation and derivation-prerequisites-to-build"
(let-values (((drv-path drv)
(build-expression->derivation %store "fail" (%current-system)
#f '())))
(let ((drv (build-expression->derivation %store "fail" (%current-system)
#f '())))
;; The only direct dependency is (%guile-for-build) and it's already
;; built.
(null? (derivation-prerequisites-to-build %store drv))))
(test-assert "derivation-prerequisites-to-build when outputs already present"
(let*-values (((builder)
'(begin (mkdir %output) #t))
((input-drv-path input-drv)
(build-expression->derivation %store "input"
(%current-system)
builder '()))
((input-path)
(derivation-output-path
(assoc-ref (derivation-outputs input-drv)
"out")))
((drv-path drv)
(build-expression->derivation %store "something"
(%current-system)
builder
`(("i" ,input-drv-path))))
((output)
(derivation-output-path
(assoc-ref (derivation-outputs drv) "out"))))
(let* ((builder '(begin (mkdir %output) #t))
(input-drv (build-expression->derivation %store "input"
(%current-system)
builder '()))
(input-path (derivation-output-path
(assoc-ref (derivation-outputs input-drv)
"out")))
(drv (build-expression->derivation %store "something"
(%current-system) builder
`(("i" ,input-drv))))
(output (derivation->output-path drv)))
;; Make sure these things are not already built.
(when (valid-path? %store input-path)
(delete-paths %store (list input-path)))
@ -451,10 +438,10 @@
(and (equal? (map derivation-input-path
(derivation-prerequisites-to-build %store drv))
(list input-drv-path))
(list (derivation-file-name input-drv)))
;; Build DRV and delete its input.
(build-derivations %store (list drv-path))
(build-derivations %store (list drv))
(delete-paths %store (list input-path))
(not (valid-path? %store input-path))
@ -464,17 +451,12 @@
(test-skip (if (getenv "GUIX_BINARY_SUBSTITUTE_URL") 0 1))
(test-assert "derivation-prerequisites-to-build and substitutes"
(let*-values (((store)
(open-connection))
((drv-path drv)
(build-expression->derivation store "prereq-subst"
(let* ((store (open-connection))
(drv (build-expression->derivation store "prereq-subst"
(%current-system)
(random 1000) '()))
((output)
(derivation-output-path
(assoc-ref (derivation-outputs drv) "out")))
((dir)
(and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL")
(output (derivation->output-path drv))
(dir (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL")
(compose uri-path string->uri))))
;; Create fake substituter data, to be read by `substitute-binary'.
(call-with-output-file (string-append dir "/nix-cache-info")
@ -494,7 +476,8 @@ Deriver: ~a~%"
output ; StorePath
(string-append dir "/example.nar") ; URL
(%current-system) ; System
(basename drv-path)))) ; Deriver
(basename
(derivation-file-name drv))))) ; Deriver
(let-values (((build download)
(derivation-prerequisites-to-build store drv))
@ -511,16 +494,16 @@ Deriver: ~a~%"
(let* ((builder '(begin
(mkdir %output)
#f)) ; fail!
(drv-path (build-expression->derivation %store "fail" (%current-system)
(drv (build-expression->derivation %store "fail" (%current-system)
builder '()))
(out-path (derivation-path->output-path drv-path)))
(out-path (derivation->output-path drv)))
(guard (c ((nix-protocol-error? c)
;; Note that the output path may exist at this point, but it
;; is invalid.
(and (string-match "build .* failed"
(nix-protocol-error-message c))
(not (valid-path? %store out-path)))))
(build-derivations %store (list drv-path))
(build-derivations %store (list drv))
#f)))
(test-assert "build-expression->derivation with two outputs"
@ -531,15 +514,15 @@ Deriver: ~a~%"
(call-with-output-file (assoc-ref %outputs "second")
(lambda (p)
(display '(world) p)))))
(drv-path (build-expression->derivation %store "double"
(drv (build-expression->derivation %store "double"
(%current-system)
builder '()
#:outputs '("out"
"second")))
(succeeded? (build-derivations %store (list drv-path))))
(succeeded? (build-derivations %store (list drv))))
(and succeeded?
(let ((one (derivation-path->output-path drv-path))
(two (derivation-path->output-path drv-path "second")))
(let ((one (derivation->output-path drv))
(two (derivation->output-path drv "second")))
(and (equal? '(hello) (call-with-input-file one read))
(equal? '(world) (call-with-input-file two read)))))))
@ -552,12 +535,12 @@ Deriver: ~a~%"
(dup2 (port->fdes p) 1)
(execl (string-append cu "/bin/uname")
"uname" "-a")))))
(drv-path (build-expression->derivation %store "uname" (%current-system)
(drv (build-expression->derivation %store "uname" (%current-system)
builder
`(("cu" ,%coreutils))))
(succeeded? (build-derivations %store (list drv-path))))
(succeeded? (build-derivations %store (list drv))))
(and succeeded?
(let ((p (derivation-path->output-path drv-path)))
(let ((p (derivation->output-path drv)))
(string-contains (call-with-input-file p read-line) "GNU")))))
(test-assert "imported-files"
@ -566,9 +549,9 @@ Deriver: ~a~%"
"guix/derivations.scm"))
("p/q" . ,(search-path %load-path "guix.scm"))
("p/z" . ,(search-path %load-path "guix/store.scm"))))
(drv-path (imported-files %store files)))
(and (build-derivations %store (list drv-path))
(let ((dir (derivation-path->output-path drv-path)))
(drv (imported-files %store files)))
(and (build-derivations %store (list drv))
(let ((dir (derivation->output-path drv)))
(every (match-lambda
((path . source)
(equal? (call-with-input-file (string-append dir "/" path)
@ -583,14 +566,13 @@ Deriver: ~a~%"
(let ((out (assoc-ref %outputs "out")))
(mkdir-p (string-append out "/guile/guix/nix"))
#t)))
(drv-path (build-expression->derivation %store
"test-with-modules"
(drv (build-expression->derivation %store "test-with-modules"
(%current-system)
builder '()
#:modules
'((guix build utils)))))
(and (build-derivations %store (list drv-path))
(let* ((p (derivation-path->output-path drv-path))
(and (build-derivations %store (list drv))
(let* ((p (derivation->output-path drv))
(s (stat (string-append p "/guile/guix/nix"))))
(eq? (stat:type s) 'directory)))))
@ -614,9 +596,10 @@ Deriver: ~a~%"
#:hash-algo 'sha256))
(succeeded? (build-derivations %store (list input1 input2))))
(and succeeded?
(not (string=? input1 input2))
(string=? (derivation-path->output-path input1)
(derivation-path->output-path input2)))))
(not (string=? (derivation-file-name input1)
(derivation-file-name input2)))
(string=? (derivation->output-path input1)
(derivation->output-path input2)))))
(test-assert "build-expression->derivation with a fixed-output input"
(let* ((builder1 '(call-with-output-file %output
@ -648,8 +631,11 @@ Deriver: ~a~%"
(%current-system)
builder3
`(("input" ,input2)))))
(and (string=? (derivation-path->output-path final1)
(derivation-path->output-path final2))
(and (string=? (derivation->output-path final1)
(derivation->output-path final2))
(string=? (derivation->output-path final1)
(derivation-path->output-path
(derivation-file-name final1)))
(build-derivations %store (list final1 final2)))))
(test-assert "build-expression->derivation with #:references-graphs"
@ -661,7 +647,7 @@ Deriver: ~a~%"
builder '()
#:references-graphs
`(("input" . ,input))))
(out (derivation-path->output-path drv)))
(out (derivation->output-path drv)))
(define (deps path . deps)
(let ((count (length deps)))
(string-append path "\n\n" (number->string count) "\n"

6
tests/guix-package.sh
View File

@ -55,7 +55,7 @@ test "`guix package --search-paths -p "$profile" | wc -l`" = 0
if guile -c '(getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)' 2> /dev/null
then
boot_make="(@@ (gnu packages base) gnu-make-boot0)"
boot_make_drv="`guix build -e "$boot_make" | tail -1`"
boot_make_drv="`guix build -e "$boot_make" | grep -v -e -debug`"
guix package --bootstrap -p "$profile" -i "$boot_make_drv"
test -L "$profile-2-link"
test -f "$profile/bin/make" && test -f "$profile/bin/guile"
@ -81,6 +81,10 @@ then
"name: hello"
test "`guix package -s "n0t4r341p4ck4g3"`" = ""
# List generations.
test "`guix package -p "$profile" -l | cut -f1 | grep guile | head -n1`" \
= " guile-bootstrap"
# Remove a package.
guix package --bootstrap -p "$profile" -r "guile-bootstrap"
test -L "$profile-3-link"

74
tests/guix-register.sh 100644
View File

@ -0,0 +1,74 @@
# GNU Guix --- Functional package management for GNU
# Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
#
# This file is part of GNU Guix.
#
# GNU 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.
#
# GNU 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 GNU Guix. If not, see <http://www.gnu.org/licenses/>.
#
# Test the 'guix-register' command-line utility.
#
guix-register --version
new_store="t-register-$$"
closure="t-register-closure-$$"
rm -rf "$new_store"
exit_hook=":"
trap "chmod -R +w $new_store ; rm -rf $new_store $closure ; \$exit_hook" EXIT
mkdir -p "$new_store/$storedir"
new_store_dir="`cd "$new_store/$storedir" ; pwd`"
new_store="`cd "$new_store" ; pwd`"
to_copy="`guix build guile-bootstrap`"
cp -r "$to_copy" "$new_store_dir"
copied="$new_store_dir/`basename $to_copy`"
# Create a file representing a closure with zero references, and with an empty
# "deriver" field.
cat >> "$closure" <<EOF
$copied
0
EOF
# Register it.
guix-register -p "$new_store" < "$closure"
# Doing it a second time shouldn't hurt.
guix-register -p "$new_store" "$closure"
# Now make sure this is recognized as valid.
NIX_IGNORE_SYMLINK_STORE=1
NIX_STORE_DIR="$new_store_dir"
NIX_LOCALSTATE_DIR="$new_store$localstatedir"
NIX_LOG_DIR="$new_store$localstatedir/log/nix"
NIX_DB_DIR="$new_store$localstatedir/nix/db"
export NIX_IGNORE_SYMLINK_STORE NIX_STORE_DIR NIX_LOCALSTATE_DIR \
NIX_LOG_DIR NIX_DB_DIR
guix-daemon --disable-chroot &
subdaemon_pid=$!
exit_hook="kill $subdaemon_pid"
# At this point the copy in $new_store must be valid, and unreferenced.
guile -c "
(use-modules (guix store))
(define s (open-connection))
(exit (and (valid-path? s \"$copied\")
(equal? (list \"$copied\") (dead-paths s))))"

38
tests/packages.scm
View File

@ -121,17 +121,16 @@
(package-source package))))
(string=? file source)))
(test-assert "return values"
(let-values (((drv-path drv)
(package-derivation %store (dummy-package "p"))))
(and (derivation-path? drv-path)
(derivation? drv))))
(test-assert "return value"
(let ((drv (package-derivation %store (dummy-package "p"))))
(and (derivation? drv)
(file-exists? (derivation-file-name drv)))))
(test-assert "package-output"
(let* ((package (dummy-package "p"))
(drv-path (package-derivation %store package)))
(and (derivation-path? drv-path)
(string=? (derivation-path->output-path drv-path)
(drv (package-derivation %store package)))
(and (derivation? drv)
(string=? (derivation->output-path drv)
(package-output %store package "out")))))
(test-assert "trivial"
@ -148,7 +147,7 @@
(display '(hello guix) p))))))))
(d (package-derivation %store p)))
(and (build-derivations %store (list d))
(let ((p (pk 'drv d (derivation-path->output-path d))))
(let ((p (pk 'drv d (derivation->output-path d))))
(equal? '(hello guix)
(call-with-input-file (string-append p "/test") read))))))
@ -164,7 +163,7 @@
(inputs `(("input" ,i)))))
(d (package-derivation %store p)))
(and (build-derivations %store (list d))
(let ((p (pk 'drv d (derivation-path->output-path d))))
(let ((p (pk 'drv d (derivation->output-path d))))
(equal? (call-with-input-file p get-bytevector-all)
(call-with-input-file i get-bytevector-all))))))
@ -183,7 +182,7 @@
(%current-system)))))))
(d (package-derivation %store p)))
(and (build-derivations %store (list d))
(let ((p (pk 'drv d (derivation-path->output-path d))))
(let ((p (pk 'drv d (derivation->output-path d))))
(eq? 'hello (call-with-input-file p read))))))
(test-assert "search paths"
@ -222,20 +221,17 @@
(equal? x (collect (package-derivation %store c)))))))
(test-assert "package-cross-derivation"
(let-values (((drv-path drv)
(package-cross-derivation %store (dummy-package "p")
"mips64el-linux-gnu")))
(and (derivation-path? drv-path)
(derivation? drv))))
(let ((drv (package-cross-derivation %store (dummy-package "p")
"mips64el-linux-gnu")))
(and (derivation? drv)
(file-exists? (derivation-file-name drv)))))
(test-assert "package-cross-derivation, trivial-build-system"
(let ((p (package (inherit (dummy-package "p"))
(build-system trivial-build-system)
(arguments '(#:builder (exit 1))))))
(let-values (((drv-path drv)
(package-cross-derivation %store p "mips64el-linux-gnu")))
(and (derivation-path? drv-path)
(derivation? drv)))))
(let ((drv (package-cross-derivation %store p "mips64el-linux-gnu")))
(derivation? drv))))
(test-assert "package-cross-derivation, no cross builder"
(let* ((b (build-system (inherit trivial-build-system)
@ -257,7 +253,7 @@
(or (location? (package-location gnu-make))
(not (package-location gnu-make)))
(let* ((drv (package-derivation %store gnu-make))
(out (derivation-path->output-path drv)))
(out (derivation->output-path drv)))
(and (build-derivations %store (list drv))
(file-exists? (string-append out "/bin/make")))))))

36
tests/store.scm
View File

@ -68,8 +68,7 @@
(test-skip (if %store 0 10))
(test-assert "dead-paths"
(let ((p (add-text-to-store %store "random-text"
(random-text) '())))
(let ((p (add-text-to-store %store "random-text" (random-text))))
(member p (dead-paths %store))))
;; FIXME: Find a test for `live-paths'.
@ -83,7 +82,7 @@
;; (d1 (derivation %store "link"
;; "/bin/sh" `("-e" ,b)
;; #:inputs `((,b) (,p1))))
;; (p2 (derivation-path->output-path d1)))
;; (p2 (derivation->output-path d1)))
;; (and (add-temp-root %store p2)
;; (build-derivations %store (list d1))
;; (valid-path? %store p1)
@ -99,7 +98,7 @@
(test-assert "references"
(let* ((t1 (add-text-to-store %store "random1"
(random-text) '()))
(random-text)))
(t2 (add-text-to-store %store "random2"
(random-text) (list t1))))
(and (equal? (list t1) (references %store t2))
@ -134,21 +133,21 @@
s `("-e" ,b)
#:env-vars `(("foo" . ,(random-text)))
#:inputs `((,b) (,s))))
(o (derivation-path->output-path d)))
(o (derivation->output-path d)))
(and (build-derivations %store (list d))
(equal? (query-derivation-outputs %store d)
(equal? (query-derivation-outputs %store (derivation-file-name d))
(list o))
(equal? (valid-derivers %store o)
(list d)))))
(list (derivation-file-name d))))))
(test-assert "no substitutes"
(let* ((s (open-connection))
(d1 (package-derivation s %bootstrap-guile (%current-system)))
(d2 (package-derivation s %bootstrap-glibc (%current-system)))
(o (map derivation-path->output-path (list d1 d2))))
(o (map derivation->output-path (list d1 d2))))
(set-build-options s #:use-substitutes? #f)
(and (not (has-substitutes? s d1))
(not (has-substitutes? s d2))
(and (not (has-substitutes? s (derivation-file-name d1)))
(not (has-substitutes? s (derivation-file-name d2)))
(null? (substitutable-paths s o))
(null? (substitutable-path-info s o)))))
@ -157,7 +156,7 @@
(test-assert "substitute query"
(let* ((s (open-connection))
(d (package-derivation s %bootstrap-guile (%current-system)))
(o (derivation-path->output-path d))
(o (derivation->output-path d))
(dir (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL")
(compose uri-path string->uri))))
;; Create fake substituter data, to be read by `substitute-binary'.
@ -178,7 +177,8 @@ Deriver: ~a~%"
o ; StorePath
(string-append dir "/example.nar") ; URL
(%current-system) ; System
(basename d)))) ; Deriver
(basename
(derivation-file-name d))))) ; Deriver
;; Remove entry from the local cache.
(false-if-exception
@ -192,7 +192,7 @@ Deriver: ~a~%"
(equal? (list o) (substitutable-paths s (list o)))
(match (pk 'spi (substitutable-path-info s (list o)))
(((? substitutable? s))
(and (equal? (substitutable-deriver s) d)
(and (string=? (substitutable-deriver s) (derivation-file-name d))
(null? (substitutable-references s))
(equal? (substitutable-nar-size s) 1234)))))))
@ -208,7 +208,7 @@ Deriver: ~a~%"
'()
#:guile-for-build
(package-derivation s %bootstrap-guile (%current-system))))
(o (derivation-path->output-path d))
(o (derivation->output-path d))
(dir (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL")
(compose uri-path string->uri))))
;; Create fake substituter data, to be read by `substitute-binary'.
@ -239,7 +239,8 @@ Deriver: ~a~%"
(compose bytevector->nix-base32-string sha256
get-bytevector-all))
(%current-system) ; System
(basename d)))) ; Deriver
(basename
(derivation-file-name d))))) ; Deriver
;; Make sure we use `substitute-binary'.
(set-build-options s #:use-substitutes? #t)
@ -258,7 +259,7 @@ Deriver: ~a~%"
'()
#:guile-for-build
(package-derivation s %bootstrap-guile (%current-system))))
(o (derivation-path->output-path d))
(o (derivation->output-path d))
(dir (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL")
(compose uri-path string->uri))))
;; Create fake substituter data, to be read by `substitute-binary'.
@ -280,7 +281,8 @@ Deriver: ~a~%"
o ; StorePath
"does-not-exist.nar" ; relative URL
(%current-system) ; System
(basename d)))) ; Deriver
(basename
(derivation-file-name d))))) ; Deriver
;; Make sure we use `substitute-binary'.
(set-build-options s #:use-substitutes? #t)

85
tests/ui.scm
View File

@ -20,6 +20,7 @@
(define-module (test-ui)
#:use-module (guix ui)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-64))
;; Test the (guix ui) module.
@ -64,6 +65,90 @@ interface, and powerful string processing.")
10)
#\newline))
(test-equal "integer"
'(1)
(string->generations "1"))
(test-equal "comma-separated integers"
'(3 7 1 4 6)
(string->generations "3,7,1,4,6"))
(test-equal "closed range"
'(4 5 6 7 8 9 10 11 12)
(string->generations "4..12"))
(test-equal "closed range, equal endpoints"
'(3)
(string->generations "3..3"))
(test-equal "indefinite end range"
'(>= 7)
(string->generations "7.."))
(test-equal "indefinite start range"
'(<= 42)
(string->generations "..42"))
(test-equal "integer, char"
#f
(string->generations "a"))
(test-equal "comma-separated integers, consecutive comma"
#f
(string->generations "1,,2"))
(test-equal "comma-separated integers, trailing comma"
#f
(string->generations "1,2,"))
(test-equal "comma-separated integers, chars"
#f
(string->generations "a,b"))
(test-equal "closed range, start > end"
#f
(string->generations "9..2"))
(test-equal "closed range, chars"
#f
(string->generations "a..b"))
(test-equal "indefinite end range, char"
#f
(string->generations "a.."))
(test-equal "indefinite start range, char"
#f
(string->generations "..a"))
(test-equal "duration, 1 day"
(make-time time-duration 0 (* 3600 24))
(string->duration "1d"))
(test-equal "duration, 1 week"
(make-time time-duration 0 (* 3600 24 7))
(string->duration "1w"))
(test-equal "duration, 1 month"
(make-time time-duration 0 (* 3600 24 30))
(string->duration "1m"))
(test-equal "duration, 1 week == 7 days"
(string->duration "1w")
(string->duration "7d"))
(test-equal "duration, 1 month == 30 days"
(string->duration "1m")
(string->duration "30d"))
(test-equal "duration, integer"
#f
(string->duration "1"))
(test-equal "duration, char"
#f
(string->duration "d"))
(test-end "ui")

2
tests/union.scm
View File

@ -108,7 +108,7 @@
builder inputs
#:modules '((guix build union)))))
(and (build-derivations %store (list (pk 'drv drv)))
(with-directory-excursion (derivation-path->output-path drv)
(with-directory-excursion (derivation->output-path drv)
(and (file-exists? "bin/touch")
(file-exists? "bin/gcc")
(file-exists? "bin/ld")