diff options
| author | Ludovic Courtès <ludo@gnu.org> | 2013-09-23 00:35:17 +0200 |
|---|---|---|
| committer | Ludovic Courtès <ludo@gnu.org> | 2013-09-23 00:35:17 +0200 |
| commit | 5608847c6f4131e8f30321fdf25289efd73f8689 (patch) | |
| tree | 5a5910165d29455b249fd4d6612078ff5cf6ced5 | |
| parent | 0c456db45bf03df61cdb71db7742a44f4328fb3d (diff) | |
| parent | f59e9eaac87b4365c646a475d44b431e43949649 (diff) | |
| download | guix-5608847c6f4131e8f30321fdf25289efd73f8689.tar.gz | |
Merge branch 'master' into core-updates
72 files changed, 2285 insertions, 646 deletions
diff --git a/.gitignore b/.gitignore index f97a3b5f3d..78b16800bf 100644 --- a/.gitignore +++ b/.gitignore @@ -76,3 +76,4 @@ stamp-h[0-9] /nix/scripts/substitute-binary /doc/images/bootstrap-graph.png /doc/images/bootstrap-graph.eps +/guix-register diff --git a/Makefile.am b/Makefile.am index bf9c1d0e91..7dc79e26e4 100644 --- a/Makefile.am +++ b/Makefile.am @@ -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 diff --git a/THANKS b/THANKS index 9dc330f998..68576f7ea0 100644 --- a/THANKS +++ b/THANKS @@ -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> diff --git a/build-aux/check-available-binaries.scm b/build-aux/check-available-binaries.scm index 8fd64fe2cb..92810795e1 100644 --- a/build-aux/check-available-binaries.scm +++ b/build-aux/check-available-binaries.scm @@ -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~%" diff --git a/build-aux/hydra/gnu-system.scm b/build-aux/hydra/gnu-system.scm index 8206be22ff..72e4c35537 100644 --- a/build-aux/hydra/gnu-system.scm +++ b/build-aux/hydra/gnu-system.scm @@ -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)) diff --git a/build-aux/hydra/guix.scm b/build-aux/hydra/guix.scm index dbc935d897..57041d695f 100644 --- a/build-aux/hydra/guix.scm +++ b/build-aux/hydra/guix.scm @@ -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)))))) diff --git a/daemon.am b/daemon.am index 069700b1b6..77bfe71987 100644 --- a/daemon.am +++ b/daemon.am @@ -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 diff --git a/doc/guix.texi b/doc/guix.texi index 5b91bc2982..90016a4496 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -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 diff --git a/gnu-system.am b/gnu-system.am index 2b81579983..e2eb043deb 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -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 \ diff --git a/gnu/packages/avahi.scm b/gnu/packages/avahi.scm index fbdc0e2834..14073b32a0 100644 --- a/gnu/packages/avahi.scm +++ b/gnu/packages/avahi.scm @@ -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 diff --git a/gnu/packages/cryptsetup.scm b/gnu/packages/cryptsetup.scm index c746e28721..8645e9e04a 100644 --- a/gnu/packages/cryptsetup.scm +++ b/gnu/packages/cryptsetup.scm @@ -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 diff --git a/gnu/packages/gdb.scm b/gnu/packages/gdb.scm index 4cf6b90cc3..5190283895 100644 --- a/gnu/packages/gdb.scm +++ b/gnu/packages/gdb.scm @@ -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/") diff --git a/gnu/packages/ghostscript.scm b/gnu/packages/ghostscript.scm index dd6c576cdf..7df1f6c17e 100644 --- a/gnu/packages/ghostscript.scm +++ b/gnu/packages/ghostscript.scm @@ -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 diff --git a/gnu/packages/glib.scm b/gnu/packages/glib.scm index fee834f9f9..815fafcbfb 100644 --- a/gnu/packages/glib.scm +++ b/gnu/packages/glib.scm @@ -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") diff --git a/gnu/packages/gnome.scm b/gnu/packages/gnome.scm new file mode 100644 index 0000000000..c66af51c98 --- /dev/null +++ b/gnu/packages/gnome.scm @@ -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 diff --git a/gnu/packages/gnupg.scm b/gnu/packages/gnupg.scm index 604ebc2941..7c0f50900a 100644 --- a/gnu/packages/gnupg.scm +++ b/gnu/packages/gnupg.scm @@ -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 diff --git a/gnu/packages/gnutls.scm b/gnu/packages/gnutls.scm index d636a9c927..766731e289 100644 --- a/gnu/packages/gnutls.scm +++ b/gnu/packages/gnutls.scm @@ -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) diff --git a/gnu/packages/grub.scm b/gnu/packages/grub.scm index 71c4fad781..8c981bf88d 100644 --- a/gnu/packages/grub.scm +++ b/gnu/packages/grub.scm @@ -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))) - '())) diff --git a/gnu/packages/gstreamer.scm b/gnu/packages/gstreamer.scm new file mode 100644 index 0000000000..7478dc3188 --- /dev/null +++ b/gnu/packages/gstreamer.scm @@ -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+))) diff --git a/gnu/packages/gtk.scm b/gnu/packages/gtk.scm index 742cbf172e..e72f7c5acc 100644 --- a/gnu/packages/gtk.scm +++ b/gnu/packages/gtk.scm @@ -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.") diff --git a/gnu/packages/libevent.scm b/gnu/packages/libevent.scm index ccca427fc4..8f2d5dad46 100644 --- a/gnu/packages/libevent.scm +++ b/gnu/packages/libevent.scm @@ -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/") diff --git a/gnu/packages/linux-initrd.scm b/gnu/packages/linux-initrd.scm index 6dd2a10e53..b62843aadd 100644 --- a/gnu/packages/linux-initrd.scm +++ b/gnu/packages/linux-initrd.scm @@ -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 diff --git a/gnu/packages/linux.scm b/gnu/packages/linux.scm index b5ed92e198..38bff72933 100644 --- a/gnu/packages/linux.scm +++ b/gnu/packages/linux.scm @@ -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") diff --git a/gnu/packages/mailutils.scm b/gnu/packages/mail.scm index 15ca939e66..b8ddcd71e1 100644 --- a/gnu/packages/mailutils.scm +++ b/gnu/packages/mail.scm @@ -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 autotools) + #: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 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 ((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+))) diff --git a/gnu/packages/netpbm.scm b/gnu/packages/netpbm.scm index d2213b8f0d..c8d3603701 100644 --- a/gnu/packages/netpbm.scm +++ b/gnu/packages/netpbm.scm @@ -57,7 +57,7 @@ ("libxml2" ,libxml2) ("perl" ,perl) ("pkg-config" ,pkg-config) - ("python" ,python) + ("python" ,python-wrapper) ("zlib" ,zlib))) (arguments `(#:phases diff --git a/gnu/packages/oggvorbis.scm b/gnu/packages/oggvorbis.scm index 2aa606ca22..589828be0a 100644 --- a/gnu/packages/oggvorbis.scm +++ b/gnu/packages/oggvorbis.scm @@ -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 diff --git a/gnu/packages/patches/avahi-localstatedir.patch b/gnu/packages/patches/avahi-localstatedir.patch new file mode 100644 index 0000000000..76377d1057 --- /dev/null +++ b/gnu/packages/patches/avahi-localstatedir.patch @@ -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 diff --git a/gnu/packages/patches/dbus-localstatedir.patch b/gnu/packages/patches/dbus-localstatedir.patch new file mode 100644 index 0000000000..61bed91b5c --- /dev/null +++ b/gnu/packages/patches/dbus-localstatedir.patch @@ -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. diff --git a/gnu/packages/patches/gnutls-fix-tests-on-32-bits-system.patch b/gnu/packages/patches/gnutls-fix-tests-on-32-bits-system.patch deleted file mode 100644 index 07d633149e..0000000000 --- a/gnu/packages/patches/gnutls-fix-tests-on-32-bits-system.patch +++ /dev/null @@ -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 - diff --git a/gnu/packages/python.scm b/gnu/packages/python.scm index 493068adde..d64ed1a131 100644 --- a/gnu/packages/python.scm +++ b/gnu/packages/python.scm @@ -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))) diff --git a/gnu/packages/qemu.scm b/gnu/packages/qemu.scm index 9c9355c4d6..6330fabcf9 100644 --- a/gnu/packages/qemu.scm +++ b/gnu/packages/qemu.scm @@ -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) diff --git a/gnu/packages/samba.scm b/gnu/packages/samba.scm index b016442908..e0199bce90 100644 --- a/gnu/packages/samba.scm +++ b/gnu/packages/samba.scm @@ -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") diff --git a/gnu/packages/system.scm b/gnu/packages/system.scm index 7c733f9575..9af0365812 100644 --- a/gnu/packages/system.scm +++ b/gnu/packages/system.scm @@ -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 diff --git a/gnu/packages/texlive.scm b/gnu/packages/texlive.scm index a0d57444e3..7c6f82b9c9 100644 --- a/gnu/packages/texlive.scm +++ b/gnu/packages/texlive.scm @@ -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") diff --git a/gnu/packages/version-control.scm b/gnu/packages/version-control.scm index 14404f0bfe..42b5d5fe99 100644 --- a/gnu/packages/version-control.scm +++ b/gnu/packages/version-control.scm @@ -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/") diff --git a/gnu/packages/xml.scm b/gnu/packages/xml.scm index 2f9d64b81a..28c99b1f8c 100644 --- a/gnu/packages/xml.scm +++ b/gnu/packages/xml.scm @@ -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 diff --git a/gnu/packages/xorg.scm b/gnu/packages/xorg.scm index 98f104b0b6..0659c8d10c 100644 --- a/gnu/packages/xorg.scm +++ b/gnu/packages/xorg.scm @@ -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) diff --git a/gnu/packages/yasm.scm b/gnu/packages/yasm.scm index 51cd3ed0a5..a990d08174 100644 --- a/gnu/packages/yasm.scm +++ b/gnu/packages/yasm.scm @@ -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") diff --git a/gnu/packages/zip.scm b/gnu/packages/zip.scm index 934acdc316..f505d053c6 100644 --- a/gnu/packages/zip.scm +++ b/gnu/packages/zip.scm @@ -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 diff --git a/gnu/system/dmd.scm b/gnu/system/dmd.scm new file mode 100644 index 0000000000..1e8767e357 --- /dev/null +++ b/gnu/system/dmd.scm @@ -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 diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm new file mode 100644 index 0000000000..b2438b9c5b --- /dev/null +++ b/gnu/system/grub.scm @@ -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 diff --git a/gnu/system/linux.scm b/gnu/system/linux.scm new file mode 100644 index 0000000000..b2daa13e06 --- /dev/null +++ b/gnu/system/linux.scm @@ -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 diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm new file mode 100644 index 0000000000..71f8e0d771 --- /dev/null +++ b/gnu/system/shadow.scm @@ -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 diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 73543896ef..df55f7c94e 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -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 (/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))))) - - (add-text-to-store store "shadow" contents '())) - -(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))))) +(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 %dmd-services + ;; Services run by dmd. + (list (mingetty-service store "tty1") + (mingetty-service store "tty2") + (mingetty-service store "tty3") + (syslog-service store))) + + (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) + + ;; 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 diff --git a/guix/build-system/cmake.scm b/guix/build-system/cmake.scm index 76a9a3befe..9461b19a2e 100644 --- a/guix/build-system/cmake.scm +++ b/guix/build-system/cmake.scm @@ -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 diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm index 03d56edadf..5f13f8ee29 100644 --- a/guix/build-system/gnu.scm +++ b/guix/build-system/gnu.scm @@ -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))) diff --git a/guix/build-system/perl.scm b/guix/build-system/perl.scm index 1ff9fd2674..6661689efb 100644 --- a/guix/build-system/perl.scm +++ b/guix/build-system/perl.scm @@ -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 diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm index b60adb182f..cf7ca7d3e1 100644 --- a/guix/build-system/python.scm +++ b/guix/build-system/python.scm @@ -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)) diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index b5404da7f0..cbdb363b4e 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -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))) diff --git a/guix/build/python-build-system.scm b/guix/build/python-build-system.scm index 84299798b0..0bb8c4d49d 100644 --- a/guix/build/python-build-system.scm +++ b/guix/build/python-build-system.scm @@ -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) diff --git a/guix/derivations.scm b/guix/derivations.scm index c05644add2..433a8f145e 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -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) '()) diff --git a/guix/download.scm b/guix/download.scm index fa76615ef2..8b1d15f273 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -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 diff --git a/guix/nar.scm b/guix/nar.scm index 29b57dc989..ea119a25fe 100644 --- a/guix/nar.scm +++ b/guix/nar.scm @@ -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) diff --git a/guix/packages.scm b/guix/packages.scm index f63727dd32..efec414675 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -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))) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 26cd28215e..a06755dc7a 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -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))))))))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 5c3947dd63..1d00e39540 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -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) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index adcaa49721..023b83e6a3 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -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"))) diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index 63f0c4f8d2..1afc93bbc9 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -446,6 +446,30 @@ PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by ;;; +;;; 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: diff --git a/guix/store.scm b/guix/store.scm index 541c7c848f..0f1e2f9466 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -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." diff --git a/guix/ui.scm b/guix/ui.scm index 720d01be02..4415997252 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -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." diff --git a/nix/guix-register/guix-register.cc b/nix/guix-register/guix-register.cc new file mode 100644 index 0000000000..0a028f0cfe --- /dev/null +++ b/nix/guix-register/guix-register.cc @@ -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; +} diff --git a/nix/libutil/gcrypt-hash.cc b/nix/libutil/gcrypt-hash.cc index b364a5747a..553f633b93 100644 --- a/nix/libutil/gcrypt-hash.cc +++ b/nix/libutil/gcrypt-hash.cc @@ -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)); diff --git a/nix/libutil/gcrypt-hash.hh b/nix/libutil/gcrypt-hash.hh index d2d40d5fb2..d93a6eb881 100644 --- a/nix/libutil/gcrypt-hash.hh +++ b/nix/libutil/gcrypt-hash.hh @@ -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); } diff --git a/test-env.in b/test-env.in index e6b13c271e..ed31f88141 100644 --- a/test-env.in +++ b/test-env.in @@ -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 $? diff --git a/tests/builders.scm b/tests/builders.scm index 1e6b62ee6a..0ed5d74a22 100644 --- a/tests/builders.scm +++ b/tests/builders.scm @@ -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"))))) diff --git a/tests/derivations.scm b/tests/derivations.scm index 9092e3acd6..4756fb9cba 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -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" diff --git a/tests/guix-package.sh b/tests/guix-package.sh index ee186ead83..b09a9c0173 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -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" diff --git a/tests/guix-register.sh b/tests/guix-register.sh new file mode 100644 index 0000000000..b76a1af54f --- /dev/null +++ b/tests/guix-register.sh @@ -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))))" diff --git a/tests/packages.scm b/tests/packages.scm index 8619011f59..706739fb70 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -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"))))))) diff --git a/tests/store.scm b/tests/store.scm index 9625a6b308..b5e0cb0eab 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -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) diff --git a/tests/ui.scm b/tests/ui.scm index 0b6f3c5815..3d5c3e7969 100644 --- a/tests/ui.scm +++ b/tests/ui.scm @@ -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") diff --git a/tests/union.scm b/tests/union.scm index 6287cffc38..cb110c3b1e 100644 --- a/tests/union.scm +++ b/tests/union.scm @@ -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") |