diff options
41 files changed, 1639 insertions, 407 deletions
@@ -2,8 +2,9 @@ #+TITLE: Hacking GNU Guix and Its Incredible Distro -Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> +Copyright © 2014 Pierre-Antoine Rault <par@rigelk.eu> Copying and distribution of this file, with or without modification, are permitted in any medium without royalty provided the copyright @@ -85,7 +86,11 @@ wrapping it, swallowing or rejecting the following s-expression, etc. Development is done using the Git distributed version control system. Thus, access to the repository is not strictly necessary. We welcome contributions in the form of patches as produced by ‘git format-patch’ sent to -guix-devel@gnu.org. Please write commit logs in the [[http://www.gnu.org/prep/standards/html_node/Change-Logs.html#Change-Logs][GNU ChangeLog format]]. +guix-devel@gnu.org. Please write commit logs in the [[http://www.gnu.org/prep/standards/html_node/Change-Logs.html#Change-Logs][GNU ChangeLog +format]]; you can check the commit history for examples. + +When posting a patch to the mailing list, use "[PATCH] ..." as a subject. You +may use your email client or the ‘git send-mail’ command. As you become a regular contributor, you may find it convenient to have write access to the repository (see below.) diff --git a/Makefile.am b/Makefile.am index 56cb6d2354..764332a001 100644 --- a/Makefile.am +++ b/Makefile.am @@ -263,7 +263,7 @@ gen-ChangeLog: mv $(distdir)/cl-t $(distdir)/ChangeLog; \ fi -# Make sure we're not shipping a file that embeds a local /nix/store file name. +# Make sure we're not shipping a file that embeds a local /gnu/store file name. assert-no-store-file-names: if grep -r --exclude=*.texi --exclude=*.info \ "$(storedir)/[a-z0-9]{32}-" $(distdir) ; \ diff --git a/configure.ac b/configure.ac index 749672f15b..d5a89c915b 100644 --- a/configure.ac +++ b/configure.ac @@ -26,11 +26,15 @@ GUIX_ASSERT_SUPPORTED_SYSTEM AC_ARG_WITH(store-dir, AC_HELP_STRING([--with-store-dir=PATH], - [path of the store (defaults to /nix/store)]), + [file name of the store (defaults to /gnu/store)]), [storedir="$withval"], - [storedir="/nix/store"]) + [storedir="/gnu/store"]) AC_SUBST(storedir) +dnl Better be verbose. +AC_MSG_CHECKING([for the store directory]) +AC_MSG_RESULT([$storedir]) + AC_ARG_ENABLE([daemon], [AS_HELP_STRING([--disable-daemon], [build the Nix daemon (C++)])], [guix_build_daemon="$enableval"], @@ -112,8 +112,8 @@ libstore_a_CPPFLAGS = \ -I$(top_builddir)/nix/libstore \ -DNIX_STORE_DIR=\"$(storedir)\" \ -DNIX_DATA_DIR=\"$(datadir)\" \ - -DNIX_STATE_DIR=\"$(localstatedir)/nix\" \ - -DNIX_LOG_DIR=\"$(localstatedir)/log/nix\" \ + -DNIX_STATE_DIR=\"$(localstatedir)/guix\" \ + -DNIX_LOG_DIR=\"$(localstatedir)/log/guix\" \ -DNIX_CONF_DIR=\"$(sysconfdir)/guix\" \ -DNIX_LIBEXEC_DIR=\"$(libexecdir)\" \ -DNIX_BIN_DIR=\"$(bindir)\" \ diff --git a/doc/guix.texi b/doc/guix.texi index 78736fadf2..701b5400f8 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -102,7 +102,7 @@ explicit inputs are visible. The result of package build functions is @dfn{cached} in the file system, in a special directory called @dfn{the store} (@pxref{The Store}). Each package is installed in a directory of its own, in the -store---by default under @file{/nix/store}. The directory name contains +store---by default under @file{/gnu/store}. The directory name contains a hash of all the inputs used to build that package; thus, changing an input yields a different directory name. @@ -165,7 +165,7 @@ between both. To do so, you must pass @command{configure} not only the same @code{--with-store-dir} value, but also the same @code{--localstatedir} value. The latter is essential because it specifies where the database that stores metadata about the store is -located, among other things. The default values are +located, among other things. The default values for Nix are @code{--with-store-dir=/nix/store} and @code{--localstatedir=/nix/var}. Note that @code{--disable-daemon} is not required if your goal is to share the store with Nix. @@ -195,7 +195,7 @@ environment. In a standard multi-user setup, Guix and its daemon---the @command{guix-daemon} program---are installed by the system -administrator; @file{/nix/store} is owned by @code{root} and +administrator; @file{/gnu/store} is owned by @code{root} and @command{guix-daemon} runs as @code{root}. Unprivileged users may use Guix tools to build packages or otherwise access the store, and the daemon will do it on their behalf, ensuring that the store is kept in a @@ -577,7 +577,7 @@ management tools it provides. When using Guix, each package ends up in the @dfn{package store}, in its own directory---something that resembles -@file{/nix/store/xxx-package-1.2}, where @code{xxx} is a base32 string. +@file{/gnu/store/xxx-package-1.2}, where @code{xxx} is a base32 string. Instead of referring to these directories, users have their own @dfn{profile}, which points to the packages that they actually want to @@ -586,10 +586,10 @@ use. These profiles are stored within each user's home directory, at For example, @code{alice} installs GCC 4.7.2. As a result, @file{/home/alice/.guix-profile/bin/gcc} points to -@file{/nix/store/@dots{}-gcc-4.7.2/bin/gcc}. Now, on the same machine, +@file{/gnu/store/@dots{}-gcc-4.7.2/bin/gcc}. Now, on the same machine, @code{bob} had already installed GCC 4.8.0. The profile of @code{bob} simply continues to point to -@file{/nix/store/@dots{}-gcc-4.8.0/bin/gcc}---i.e., both versions of GCC +@file{/gnu/store/@dots{}-gcc-4.8.0/bin/gcc}---i.e., both versions of GCC coexist on the same system without any interference. The @command{guix package} command is the central tool to manage @@ -621,7 +621,7 @@ collected. @cindex reproducible builds Finally, Guix takes a @dfn{purely functional} approach to package management, as described in the introduction (@pxref{Introduction}). -Each @file{/nix/store} package directory name contains a hash of all the +Each @file{/gnu/store} package directory name contains a hash of all the inputs that were used to build that package---compiler, libraries, build scripts, etc. This direct correspondence allows users to make sure a given package installation matches the current state of their @@ -632,7 +632,7 @@ machines (@pxref{Invoking guix-daemon, container}). @cindex substitute This foundation allows Guix to support @dfn{transparent binary/source -deployment}. When a pre-built binary for a @file{/nix/store} path is +deployment}. When a pre-built binary for a @file{/gnu/store} path is available from an external source---a @dfn{substitute}, Guix just downloads it@footnote{@c XXX: Remove me when outdated. As of version @value{VERSION}, substitutes are downloaded from @@ -699,7 +699,9 @@ such as @code{guile-1.8.8}. If no version number is specified, the newest available version will be selected. In addition, @var{package} may contain a colon, followed by the name of one of the outputs of the package, as in @code{gcc:doc} or @code{binutils-2.22:lib} -(@pxref{Packages with Multiple Outputs}). +(@pxref{Packages with Multiple Outputs}). Packages with a corresponding +name (and optionally version) are searched for among the GNU +distribution modules (@pxref{Package Modules}). @cindex propagated inputs Sometimes packages have @dfn{propagated inputs}: these are dependencies @@ -789,21 +791,6 @@ suggest setting these variables to @code{@var{profile}/include} and @itemx -p @var{profile} Use @var{profile} instead of the user's default profile. -@item --dry-run -@itemx -n -Show what would be done without actually doing it. - -@item --fallback -When substituting a pre-built binary fails, fall back to building -packages locally. - -@item --no-substitutes -Do not use substitutes for build products. That is, always build things -locally instead of allowing downloads of pre-built binaries. - -@item --max-silent-time=@var{seconds} -Same as for @command{guix build} (@pxref{Invoking guix build}). - @item --verbose Produce verbose output. In particular, emit the environment's build log on the standard error port. @@ -918,6 +905,10 @@ Consequently, this command must be used with care. @end table +Finally, since @command{guix package} may actually start build +processes, it supports all the common build options that @command{guix +build} supports (@pxref{Invoking guix build, common build options}). + @node Packages with Multiple Outputs @section Packages with Multiple Outputs @@ -974,10 +965,10 @@ guix package}). @cindex garbage collector Packages that are installed but not used may be @dfn{garbage-collected}. The @command{guix gc} command allows users to explicitly run the garbage -collector to reclaim space from the @file{/nix/store} directory. +collector to reclaim space from the @file{/gnu/store} directory. The garbage collector has a set of known @dfn{roots}: any file under -@file{/nix/store} reachable from a root is considered @dfn{live} and +@file{/gnu/store} reachable from a root is considered @dfn{live} and cannot be deleted; any other file is considered @dfn{dead} and may be deleted. The set of garbage collector roots includes default user profiles, and may be augmented with @command{guix build --root}, for @@ -997,7 +988,7 @@ information. The available options are listed below: @table @code @item --collect-garbage[=@var{min}] @itemx -C [@var{min}] -Collect garbage---i.e., unreachable @file{/nix/store} files and +Collect garbage---i.e., unreachable @file{/gnu/store} files and sub-directories. This is the default operation when no option is specified. @@ -1170,13 +1161,13 @@ containing the @code{gui} output of the @code{git} package and the main output of @code{emacs}: @example -guix archive --export git:gui /nix/store/...-emacs-24.3 > great.nar +guix archive --export git:gui /gnu/store/...-emacs-24.3 > great.nar @end example If the specified packages are not built yet, @command{guix archive} automatically builds them. The build process may be controlled with the same options that can be passed to the @command{guix build} command -(@pxref{Invoking guix build}). +(@pxref{Invoking guix build, common build options}). @c ********************************************************************* @@ -1192,7 +1183,7 @@ turned into concrete build actions. Build actions are performed by the Guix daemon, on behalf of users. In a standard setup, the daemon has write access to the store---the -@file{/nix/store} directory---whereas users do not. The recommended +@file{/gnu/store} directory---whereas users do not. The recommended setup also has the daemon perform builds in chroots, under a specific build users, to minimize interference with the rest of the system. @@ -1223,10 +1214,11 @@ example, the package definition, or @dfn{recipe}, for the GNU Hello package looks like this: @example -(use-modules (guix packages) - (guix download) - (guix build-system gnu) - (guix licenses)) +(define-module (gnu packages hello) + #:use-module (guix packages) + #:use-module (guix download) + #:use-module (guix build-system gnu) + #:use-module (guix licenses)) (define hello (package @@ -1248,13 +1240,19 @@ package looks like this: @noindent Without being a Scheme expert, the reader may have guessed the meaning -of the various fields here. This expression binds variable @var{hello} +of the various fields here. This expression binds variable @code{hello} to a @code{<package>} object, which is essentially a record (@pxref{SRFI-9, Scheme records,, guile, GNU Guile Reference Manual}). This package object can be inspected using procedures found in the @code{(guix packages)} module; for instance, @code{(package-name hello)} returns---surprise!---@code{"hello"}. +In the example above, @var{hello} is defined into a module of its own, +@code{(gnu packages hello)}. Technically, this is not strictly +necessary, but it is convenient to do so: all the packages defined in +modules under @code{(gnu packages @dots{})} are automatically known to +the command-line tools (@pxref{Package Modules}). + There are a few points worth noting in the above package definition: @itemize @@ -1342,7 +1340,7 @@ definition to a new upstream version can be partly automated by the Behind the scenes, a derivation corresponding to the @code{<package>} object is first computed by the @code{package-derivation} procedure. -That derivation is stored in a @code{.drv} file under @file{/nix/store}. +That derivation is stored in a @code{.drv} file under @file{/gnu/store}. The build actions it prescribes may then be realized by using the @code{build-derivations} procedure (@pxref{The Store}). @@ -1381,7 +1379,7 @@ Configure and Build System}). @cindex store paths Conceptually, the @dfn{store} is where derivations that have been -successfully built are stored---by default, under @file{/nix/store}. +successfully built are stored---by default, under @file{/gnu/store}. Sub-directories in the store are referred to as @dfn{store paths}. The store has an associated database that contains information such has the store paths referred to by each store path, and the list of @emph{valid} @@ -1526,7 +1524,7 @@ to a Bash executable in the store: (derivation store "foo" bash `("-e" ,builder) #:env-vars '(("HOME" . "/homeless")))) -@result{} #<derivation /nix/store/@dots{}-foo.drv => /nix/store/@dots{}-foo> +@result{} #<derivation /gnu/store/@dots{}-foo.drv => /gnu/store/@dots{}-foo> @end lisp As can be guessed, this primitive is cumbersome to use directly. An @@ -1570,13 +1568,13 @@ containing one file: @lisp (let ((builder '(let ((out (assoc-ref %outputs "out"))) - (mkdir out) ; create /nix/store/@dots{}-goo + (mkdir out) ; create /gnu/store/@dots{}-goo (call-with-output-file (string-append out "/test") (lambda (p) (display '(hello guix) p)))))) (build-expression->derivation store "goo" builder)) -@result{} #<derivation /nix/store/@dots{}-goo.drv => @dots{}> +@result{} #<derivation /gnu/store/@dots{}-goo.drv => @dots{}> @end lisp @cindex strata of code @@ -1654,7 +1652,7 @@ effect, one must use @code{run-with-store}: @example (run-with-store (open-connection) (profile.sh)) -@result{} /nix/store/...-profile.sh +@result{} /gnu/store/...-profile.sh @end example The main syntactic forms to deal with monads in general are described @@ -1729,7 +1727,7 @@ like this: grep "/bin:" sed "/bin\n")) @end example -In this example, the resulting @file{/nix/store/@dots{}-profile.sh} file +In this example, the resulting @file{/gnu/store/@dots{}-profile.sh} file will references @var{coreutils}, @var{grep}, and @var{sed}, thereby preventing them from being garbage-collected during its lifetime. @end deffn @@ -1789,10 +1787,14 @@ guix build @var{options} @var{package-or-derivation}@dots{} @var{package-or-derivation} may be either the name of a package found in the software distribution such as @code{coreutils} or @code{coreutils-8.20}, or a derivation such as -@file{/nix/store/@dots{}-coreutils-8.19.drv}. Alternatively, the -@code{--expression} option may be used to specify a Scheme expression -that evaluates to a package; this is useful when disambiguation among -several same-named packages or package variants is needed. +@file{/gnu/store/@dots{}-coreutils-8.19.drv}. In the former case, a +package with the corresponding name (and optionally version) is searched +for among the GNU distribution modules (@pxref{Package Modules}). + +Alternatively, the @code{--expression} option may be used to specify a +Scheme expression that evaluates to a package; this is useful when +disambiguation among several same-named packages or package variants is +needed. The @var{options} may be zero or more of the following: @@ -1816,7 +1818,7 @@ Build the packages' source derivations, rather than the packages themselves. For instance, @code{guix build -S gcc} returns something like -@file{/nix/store/@dots{}-gcc-4.7.2.tar.bz2}, which is GCC's source tarball. +@file{/gnu/store/@dots{}-gcc-4.7.2.tar.bz2}, which is GCC's source tarball. The returned source tarball is the result of applying any patches and code snippets specified in the package's @code{origin} (@pxref{Defining @@ -1843,6 +1845,37 @@ configuration triplets,, configure, GNU Configure and Build System}). Return the derivation paths, not the output paths, of the given packages. +@item --root=@var{file} +@itemx -r @var{file} +Make @var{file} a symlink to the result, and register it as a garbage +collector root. + +@item --log-file +Return the build log file names for the given +@var{package-or-derivation}s, or raise an error if build logs are +missing. + +This works regardless of how packages or derivations are specified. For +instance, the following invocations are equivalent: + +@example +guix build --log-file `guix build -d guile` +guix build --log-file `guix build guile` +guix build --log-file guile +guix build --log-file -e '(@@ (gnu packages guile) guile-2.0)' +@end example + + +@end table + +@cindex common build options +In addition, a number of options that control the build process are +common to @command{guix build} and other commands that can spawn builds, +such as @command{guix package} or @command{guix archive}. These are the +following: + +@table @code + @item --keep-failed @itemx -K Keep the build tree of failed builds. Thus, if a build fail, its build @@ -1870,36 +1903,22 @@ instead of offloading builds to remote machines. When the build or substitution process remains silent for more than @var{seconds}, terminate it and report a build failure. -@item --cores=@var{n} -@itemx -c @var{n} -Allow the use of up to @var{n} CPU cores for the build. The special -value @code{0} means to use as many CPU cores as available. +@item --timeout=@var{seconds} +Likewise, when the build or substitution process lasts for more than +@var{seconds}, terminate it and report a build failure. -@item --root=@var{file} -@itemx -r @var{file} -Make @var{file} a symlink to the result, and register it as a garbage -collector root. +By default there is no timeout. This behavior can be restored with +@code{--timeout=0}. @item --verbosity=@var{level} Use the given verbosity level. @var{level} must be an integer between 0 and 5; higher means more verbose output. Setting a level of 4 or more may be helpful when debugging setup issues with the build daemon. -@item --log-file -Return the build log file names for the given -@var{package-or-derivation}s, or raise an error if build logs are -missing. - -This works regardless of how packages or derivations are specified. For -instance, the following invocations are equivalent: - -@example -guix build --log-file `guix build -d guile` -guix build --log-file `guix build guile` -guix build --log-file guile -guix build --log-file -e '(@@ (gnu packages guile) guile-2.0)' -@end example - +@item --cores=@var{n} +@itemx -c @var{n} +Allow the use of up to @var{n} CPU cores for the build. The special +value @code{0} means to use as many CPU cores as available. @end table @@ -2184,7 +2203,7 @@ the load. To check whether a package has a @code{debug} output, use @section Package Modules From a programming viewpoint, the package definitions of the -distribution are provided by Guile modules in the @code{(gnu packages +GNU distribution are provided by Guile modules in the @code{(gnu packages @dots{})} name space@footnote{Note that packages under the @code{(gnu packages @dots{})} module name space are not necessarily ``GNU packages''. This module naming scheme follows the usual Guile module @@ -2193,8 +2212,19 @@ as part of the GNU system, and @code{packages} identifies modules that define packages.} (@pxref{Modules, Guile modules,, guile, GNU Guile Reference Manual}). For instance, the @code{(gnu packages emacs)} module exports a variable named @code{emacs}, which is bound to a -@code{<package>} object (@pxref{Defining Packages}). The @code{(gnu -packages)} module provides facilities for searching for packages. +@code{<package>} object (@pxref{Defining Packages}). + +The @code{(gnu packages @dots{})} module name space is special: it is +automatically scanned for packages by the command-line tools. For +instance, when running @code{guix package -i emacs}, all the @code{(gnu +packages @dots{})} modules are scanned until one that exports a package +object whose name is @code{emacs} is found. This package search +facility is implemented in the @code{(gnu packages)} module. + +Users can store package definitions in modules with different +names---e.g., @code{(my-packages emacs)}. In that case, commands such +as @command{guix package} and @command{guix build} have to be used with +the @code{-e} option so that they know where to find the package. The distribution is fully @dfn{bootstrapped} and @dfn{self-contained}: each package is built based solely on other packages in the @@ -2240,6 +2270,15 @@ called @code{gnew}, you may run this command from the Guix build tree: Using @code{--keep-failed} makes it easier to debug build failures since it provides access to the failed build tree. +If the package is unknown to the @command{guix} command, it may be that +the source file contains a syntax error, or lacks a @code{define-public} +clause to export the package variable. To figure it out, you may load +the module from Guile to get more information about the actual error: + +@example +./pre-inst-env guile -c '(use-modules (gnu packages gnew))' +@end example + Once your package builds correctly, please send us a patch (@pxref{Contributing}). Well, if you need help, we will be happy to help you too. Once the patch is committed in the Guix repository, the @@ -2452,7 +2491,7 @@ etc., at which point we have a working C tool chain. Bootstrapping is complete when we have a full tool chain that does not depend on the pre-built bootstrap tools discussed above. This no-dependency requirement is verified by checking whether the files of -the final tool chain contain references to the @file{/nix/store} +the final tool chain contain references to the @file{/gnu/store} directories of the bootstrap inputs. The process that leads to this ``final'' tool chain is described by the package definitions found in the @code{(gnu packages base)} module. @@ -2754,10 +2793,10 @@ deco,,, dmd, GNU dmd Manual}). @chapter Contributing This project is a cooperative effort, and we need your help to make it -grow! Please get in touch with us on @email{guix-devel@@gnu.org}. We -welcome ideas, bug reports, patches, and anything that may be helpful to -the project. We particularly welcome help on packaging -(@pxref{Packaging Guidelines}). +grow! Please get in touch with us on @email{guix-devel@@gnu.org} and +@code{#guix} on the Freenode IRC network. We welcome ideas, bug +reports, patches, and anything that may be helpful to the project. We +particularly welcome help on packaging (@pxref{Packaging Guidelines}). Please see the @url{http://git.savannah.gnu.org/cgit/guix.git/tree/HACKING, diff --git a/gnu-system.am b/gnu-system.am index 97dc92cdfc..9f4f959d46 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -1,7 +1,7 @@ # GNU Guix --- Functional package management for GNU # Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> # Copyright © 2013 Andreas Enge <andreas@enge.fr> -# Copyright © 2013 Mark H Weaver <mhw@netris.org> +# Copyright © 2013, 2014 Mark H Weaver <mhw@netris.org> # # This file is part of GNU Guix. # @@ -139,10 +139,12 @@ GNU_SYSTEM_MODULES = \ gnu/packages/lsof.scm \ gnu/packages/lua.scm \ gnu/packages/lvm.scm \ + gnu/packages/lynx.scm \ gnu/packages/m4.scm \ gnu/packages/mail.scm \ gnu/packages/make-bootstrap.scm \ gnu/packages/maths.scm \ + gnu/packages/messaging.scm \ gnu/packages/mit-krb5.scm \ gnu/packages/moe.scm \ gnu/packages/mpd.scm \ @@ -174,6 +176,7 @@ GNU_SYSTEM_MODULES = \ gnu/packages/popt.scm \ gnu/packages/pth.scm \ gnu/packages/pulseaudio.scm \ + gnu/packages/pretty-print.scm \ gnu/packages/python.scm \ gnu/packages/qemu.scm \ gnu/packages/qt.scm \ @@ -249,6 +252,8 @@ dist_patch_DATA = \ gnu/packages/patches/bigloo-gc-shebangs.patch \ gnu/packages/patches/binutils-ld-new-dtags.patch \ gnu/packages/patches/binutils-loongson-workaround.patch \ + gnu/packages/patches/bitlbee-fix-tests.patch \ + gnu/packages/patches/bitlbee-memset-fix.patch \ gnu/packages/patches/cdparanoia-fpic.patch \ gnu/packages/patches/cmake-fix-tests.patch \ gnu/packages/patches/coreutils-dummy-man.patch \ @@ -318,6 +323,7 @@ dist_patch_DATA = \ gnu/packages/patches/slim-session.patch \ gnu/packages/patches/slim-config.patch \ gnu/packages/patches/slim-sigusr1.patch \ + gnu/packages/patches/source-highlight-regexrange-test.patch \ gnu/packages/patches/tcsh-fix-autotest.patch \ gnu/packages/patches/teckit-cstdio.patch \ gnu/packages/patches/valgrind-glibc.patch \ diff --git a/gnu/packages/admin.scm b/gnu/packages/admin.scm index 6998996523..ffedfd3f44 100644 --- a/gnu/packages/admin.scm +++ b/gnu/packages/admin.scm @@ -36,6 +36,9 @@ #:select (tar)) #:use-module ((gnu packages compression) #:select (gzip)) + #:use-module (gnu packages bison) + #:use-module (gnu packages flex) + #:use-module (gnu packages glib) #:use-module (gnu packages pkg-config)) (define-public dmd @@ -429,3 +432,53 @@ connection alive.") reference implementation of all aspects of DHCP, through a suite of DHCP tools: server, client, and relay agent.") (license isc))) + +(define-public libpcap + (package + (name "libpcap") + (version "1.5.3") + (source (origin + (method url-fetch) + (uri (string-append "http://www.tcpdump.org/release/libpcap-" + version ".tar.gz")) + (sha256 + (base32 + "14wyjywrdi1ikaj6yc9c72m6m2r64z94lb0gm7k1a3q6q5cj3scs")))) + (build-system gnu-build-system) + (native-inputs `(("bison" ,bison) ("flex" ,flex))) + (arguments '(#:tests? #f)) ; no 'check' target + (home-page "http://www.tcpdump.org") + (synopsis "Network packet capture library") + (description + "libpcap is an interface for user-level packet capture. It provides a +portable framework for low-level network monitoring. Applications include +network statistics collection, security monitoring, network debugging, etc.") + + ;; fad-*.c and a couple other files are BSD-4, but the rest is BSD-3. + (license bsd-3))) + +(define-public jnettop + (package + (name "jnettop") + (version "0.13.0") + (source (origin + (method url-fetch) + (uri (string-append "http://jnettop.kubs.info/dist/jnettop-" + version ".tar.gz")) + (sha256 + (base32 + "1855np7c4b0bqzhf1l1dyzxb90fpnvrirdisajhci5am6als31z9")))) + (build-system gnu-build-system) + (native-inputs + `(("pkg-config" ,pkg-config))) + (inputs + `(("glib" ,glib) + ("ncurses" ,ncurses) + ("libpcap" ,libpcap))) + (home-page "http://jnettop.kubs.info/") + (synopsis "Visualize network traffic by bandwidth use") + (description + "Jnettop is a traffic visualiser, which captures traffic going +through the host it is running from and displays streams sorted +by bandwidth they use.") + (license gpl2+))) diff --git a/gnu/packages/bdw-gc.scm b/gnu/packages/bdw-gc.scm index b223721520..1955cd3ee1 100644 --- a/gnu/packages/bdw-gc.scm +++ b/gnu/packages/bdw-gc.scm @@ -29,9 +29,8 @@ (version "7.2d") (source (origin (method url-fetch) - (uri (string-append - "http://www.hpl.hp.com/personal/Hans_Boehm/gc/gc_source/gc-" - version ".tar.gz")) + (uri (string-append "http://www.hboehm.info/gc/gc_source/gc-" + version ".tar.gz")) (sha256 (base32 "0phwa5driahnpn79zqff14w9yc8sn3599cxz91m78hqdcpl0mznr")))) @@ -58,10 +57,9 @@ simple collector interface. Alternatively, the garbage collector may be used as a leak detector for C or C++ programs, though that is not its primary goal.") - (home-page "http://www.hpl.hp.com/personal/Hans_Boehm/gc/") + (home-page "http://www.hboehm.info/gc/") - (license - (x11-style "http://www.hpl.hp.com/personal/Hans_Boehm/gc/license.txt")))) + (license (x11-style (string-append home-page "license.txt"))))) (define-public libatomic-ops (package @@ -70,7 +68,7 @@ C or C++ programs, though that is not its primary goal.") (source (origin (method url-fetch) (uri (string-append - "http://www.hpl.hp.com/personal/Hans_Boehm/gc/gc_source/libatomic_ops-" + "http://www.hboehm.info/gc/gc_source/libatomic_ops-" version ".tar.gz")) (sha256 (base32 @@ -83,7 +81,7 @@ C or C++ programs, though that is not its primary goal.") memory update operations on a number architectures. These might allow you to write code that does more interesting things in signal handlers, write lock-free code, experiment with thread programming paradigms, etc.") - (home-page "http://www.hpl.hp.com/research/linux/atomic_ops/") + (home-page "https://github.com/ivmai/libatomic_ops/") ;; Some source files are X11-style, others are GPLv2+. (license gpl2+))) @@ -93,9 +91,8 @@ lock-free code, experiment with thread programming paradigms, etc.") (version "7.4.0") (source (origin (method url-fetch) - (uri (string-append - "http://www.hpl.hp.com/personal/Hans_Boehm/gc/gc_source/gc-" - version ".tar.gz")) + (uri (string-append "http://www.hboehm.info/gc/gc_source/gc-" + version ".tar.gz")) (sha256 (base32 "10z2nph62ilab063wygg2lv0jxlsbcf2az9w1lx01jzqj5lzry31")))) diff --git a/gnu/packages/gnupg.scm b/gnu/packages/gnupg.scm index e06865d196..16ca8ae661 100644 --- a/gnu/packages/gnupg.scm +++ b/gnu/packages/gnupg.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> +;;; Copyright © 2014 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -209,6 +210,31 @@ components), libgpg-error (centralized GnuPG error values), and libskba (working with X.509 certificates and CMS data).") (license gpl3+))) +(define-public gnupg-1 + (package (inherit gnupg) + (version "1.4.16") + (source + (origin + (method url-fetch) + (uri (string-append "mirror://gnupg/gnupg/gnupg-" version + ".tar.bz2")) + (sha256 + (base32 + "0bsa1yqa3ybhvmc4ys73amdpcmckrlq1fsxjl2980cxada778fvv")))) + (inputs + `(("zlib" ,guix:zlib) + ("bzip2" ,guix:bzip2) + ("curl" ,curl) + ("readline" ,readline) + ("libgpg-error" ,libgpg-error))) + (arguments + `(#:phases (alist-cons-after + 'unpack 'patch-check-sh + (lambda _ + (substitute* "checks/Makefile.in" + (("/bin/sh") (which "bash")))) + %standard-phases))))) + (define-public gpgme (package (name "gpgme") diff --git a/gnu/packages/gnutls.scm b/gnu/packages/gnutls.scm index 915f6f8c8f..0391f54126 100644 --- a/gnu/packages/gnutls.scm +++ b/gnu/packages/gnutls.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. @@ -63,7 +63,7 @@ specifications.") (define-public gnutls (package (name "gnutls") - (version "3.2.11") + (version "3.2.12") (source (origin (method url-fetch) (uri @@ -75,8 +75,12 @@ specifications.") "/gnutls-" version ".tar.xz")) (sha256 (base32 - "1hgk3k8f6wqijca3bsjbfn8pzyfva509y4j2vaxhm4ynfa5cai5q")))) + "0195nliarszq5mginli6d2f5z7ljnd7mwa46iy9z8pkcgy56khbl")))) (build-system gnu-build-system) + (arguments + ;; Work around build issue reported at + ;; <https://lists.gnu.org/archive/html/guix-devel/2014-03/msg00027.html>. + '(#:make-flags '("CPPFLAGS=-DENABLE_RSA_EXPORT"))) (native-inputs `(("pkg-config" ,pkg-config))) (inputs diff --git a/gnu/packages/hurd.scm b/gnu/packages/hurd.scm index 3edccbdd1c..f1e7dbc9dc 100644 --- a/gnu/packages/hurd.scm +++ b/gnu/packages/hurd.scm @@ -22,7 +22,9 @@ #:use-module (guix packages) #:use-module (guix build-system gnu) #:use-module (gnu packages flex) - #:use-module (gnu packages bison)) + #:use-module (gnu packages bison) + #:use-module (gnu packages perl) + #:use-module (gnu packages autotools)) (define-public gnumach-headers (package @@ -86,3 +88,43 @@ and to compile the GNU C library for the Hurd. Also,you will need it for other software in the GNU system that uses Mach-based inter-process communication.") (license gpl2+))) + +(define-public hurd-headers + (package + (name "hurd-headers") + (version "0.5") + (source (origin + (method url-fetch) + (uri (string-append "mirror://gnu/hurd/hurd-" + version ".tar.gz")) + (sha256 + (base32 + "0lvkz3r0ngb4bsn2hzdc9vjpyrfa3ls36jivrvy1n7f7f55zan7q")))) + (build-system gnu-build-system) + (native-inputs + `(;; Autoconf shouldn't be necessary but there seems to be a bug in the + ;; build system triggering its use. + ("autoconf" ,autoconf) + + ("mig" ,mig))) + (arguments + `(#:phases (alist-replace + 'install + (lambda _ + (zero? (system* "make" "install-headers" "no_deps=t"))) + (alist-delete 'build %standard-phases)) + + #:configure-flags '(;; Pretend we're on GNU/Hurd; 'configure' wants + ;; that. + "--host=i686-pc-gnu" + + ;; Reduce set of dependencies. + "--without-parted") + + #:tests? #f)) + (home-page "http://www.gnu.org/software/hurd/hurd.html") + (synopsis "GNU Hurd headers") + (description + "This package provides C headers of the GNU Hurd, used to build the GNU C +Library and other user programs.") + (license gpl2+))) diff --git a/gnu/packages/linux.scm b/gnu/packages/linux.scm index 3fca5dfaf9..e1668b1d6b 100644 --- a/gnu/packages/linux.scm +++ b/gnu/packages/linux.scm @@ -40,6 +40,7 @@ #:use-module (guix packages) #:use-module (guix download) #:use-module (guix build-system gnu) + #:use-module (guix build-system cmake) #:use-module (guix build-system python)) (define-public (system->linux-architecture arch) @@ -920,3 +921,27 @@ part of this problem by allowing users to run file system implementations as user-space processes.") (license (list lgpl2.1 ; library gpl2+)))) ; command-line utilities + +(define-public unionfs-fuse + (package + (name "unionfs-fuse") + (version "0.26") + (source (origin + (method url-fetch) + (uri (string-append + "http://podgorny.cz/unionfs-fuse/releases/unionfs-fuse-" + version ".tar.xz")) + (sha256 + (base32 + "0qpnr4czgc62vsfnmv933w62nq3xwcbnvqch72qakfgca75rsp4d")))) + (build-system cmake-build-system) + (inputs `(("fuse" ,fuse))) + (arguments '(#:tests? #f)) ; no tests + (home-page "http://podgorny.cz/moin/UnionFsFuse") + (synopsis "User-space union file system") + (description + "UnionFS-FUSE is a flexible union file system implementation in user +space, using the FUSE library. Mounting a union file system allows you to +\"aggregate\" the contents of several directories into a single mount point. +UnionFS-FUSE additionally supports copy-on-write.") + (license bsd-3))) diff --git a/gnu/packages/lynx.scm b/gnu/packages/lynx.scm new file mode 100644 index 0000000000..a87316643d --- /dev/null +++ b/gnu/packages/lynx.scm @@ -0,0 +1,86 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Mark H Weaver <mhw@netris.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 packages lynx) + #:use-module ((guix licenses) #:select (gpl2)) + #:use-module (guix packages) + #:use-module (guix download) + #:use-module (guix build-system gnu) + #:use-module (gnu packages pkg-config) + #:use-module (gnu packages perl) + #:use-module (gnu packages ncurses) + #:use-module (gnu packages libidn) + #:use-module (gnu packages gnutls) + #:use-module (gnu packages gnupg) + #:use-module (gnu packages zip) + #:use-module (gnu packages compression)) + +(define-public lynx + (package + (name "lynx") + (version "2.8.8") + (source (origin + (method url-fetch) + (uri (string-append "http://lynx.isc.org/lynx" version + "/lynx" version ".tar.bz2")) + (sha256 + (base32 "00jcfmx4bxnrzywzzlllz3z45a2mc4fl91ca5lrzz1pyr1s1qnm2")))) + (build-system gnu-build-system) + (native-inputs `(("pkg-config" ,pkg-config) + ("perl" ,perl))) + (inputs `(("ncurses" ,ncurses) + ("libidn" ,libidn) + ("gnutls" ,gnutls) + ("libgcrypt" ,libgcrypt) + ("unzip" ,unzip) + ("zlib" ,zlib) + ("gzip" ,gzip) + ("bzip2" ,bzip2))) + (arguments + `(#:configure-flags '("--with-pkg-config" + "--with-screen=ncurses" + "--with-zlib" + "--with-bzlib" + "--with-gnutls" + ;; "--with-socks5" ; XXX TODO + "--enable-widec" + "--enable-ascii-ctypes" + "--enable-local-docs" + "--enable-htmlized-cfg" + "--enable-gzip-help" + "--enable-nls" + "--enable-ipv6") + #:tests? #f ; no check target + #:phases (alist-replace + 'install + (lambda* (#:key (make-flags '()) #:allow-other-keys) + (zero? (apply system* "make" "install-full" make-flags))) + %standard-phases))) + (synopsis "Text Web Browser") + (description + "Lynx is a fully-featured World Wide Web (WWW) client for users running +cursor-addressable, character-cell display devices. It will display Hypertext +Markup Language (HTML) documents containing links to files on the local +system, as well as files on remote systems running http, gopher, ftp, wais, +nntp, finger, or cso/ph/qi servers. Lynx can be used to access information on +the WWW, or to build information systems intended primarily for local +access.") + (home-page "http://lynx.isc.org/") + (license gpl2))) + +;;; lynx.scm ends here diff --git a/gnu/packages/messaging.scm b/gnu/packages/messaging.scm new file mode 100644 index 0000000000..c1a755ef84 --- /dev/null +++ b/gnu/packages/messaging.scm @@ -0,0 +1,123 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Mark H Weaver <mhw@netris.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 packages messaging) + #:use-module ((guix licenses) + #:select (gpl2+ gpl2 lgpl2.1 bsd-2)) + #:use-module (guix packages) + #:use-module (guix download) + #:use-module (guix build-system gnu) + #:use-module (gnu packages) + #:use-module (gnu packages gnupg) + #:use-module (gnu packages pkg-config) + #:use-module (gnu packages glib) + #:use-module (gnu packages gnutls) + #:use-module (gnu packages python) + #:use-module (gnu packages perl) + #:use-module (gnu packages compression) + #:use-module (gnu packages check)) + +(define-public libotr + (package + (name "libotr") + (version "4.0.0") + (source (origin + (method url-fetch) + (uri (string-append "https://otr.cypherpunks.ca/libotr-" + version ".tar.gz")) + (sha256 + (base32 "1d4k0b7v4d3scwm858cmqr9c6xgd6ppla1vk4x2yg64q82a1k49z")))) + (build-system gnu-build-system) + (propagated-inputs + `(("libgcrypt" ,libgcrypt))) ; libotr headers include gcrypt.h + (inputs `(("libgpg-error" ,libgpg-error))) + (arguments + `(#:configure-flags '("--with-pic"))) + (synopsis "Off-the-Record (OTR) Messaging Library and Toolkit") + (description + "OTR allows you to have private conversations over instant messaging by +providing: +* Encryption: No one else can read your instant messages. +* Authentication: You are assured the correspondent is who you think it is. +* Deniability: The messages you send do not have digital signatures that are + checkable by a third party. Anyone can forge messages after a conversation + to make them look like they came from you. However, during a conversation, + your correspondent is assured the messages he sees are authentic and + unmodified. +* Perfect forward secrecy: If you lose control of your private keys, no + previous conversation is compromised.") + (home-page "https://otr.cypherpunks.ca/") + (license (list lgpl2.1 gpl2)))) + +(define-public libotr-3 + (package (inherit libotr) + (version "3.2.1") + (source (origin + (method url-fetch) + (uri (string-append "https://otr.cypherpunks.ca/libotr-" + version ".tar.gz")) + (sha256 + (base32 "1x6dd4rh499hdraiqfhz81igrj0a5rs0gjhc8l4sljwqhjjyla6l")))))) + +(define-public bitlbee + (package + (name "bitlbee") + (version "3.2.1") + (source (origin + (method url-fetch) + (uri (string-append "http://get.bitlbee.org/src/bitlbee-" + version ".tar.gz")) + (sha256 + (base32 "0n8g5452i5qap43zxb83gxp01d48psf6rr3k1q7z6a3dgpfi3x00")) + (patches (list (search-patch "bitlbee-memset-fix.patch") + (search-patch "bitlbee-fix-tests.patch"))))) + (build-system gnu-build-system) + (native-inputs `(("pkg-config" ,pkg-config) + ("check" ,check))) + (inputs `(("glib" ,glib) + ("libotr" ,libotr-3) + ("gnutls" ,gnutls) + ("zlib" ,zlib) ; Needed to satisfy "pkg-config --exists gnutls" + ("python" ,python-2) + ("perl" ,perl))) + (arguments + `(#:phases (alist-cons-after + 'install 'install-etc + (lambda* (#:key (make-flags '()) #:allow-other-keys) + (zero? (apply system* "make" "install-etc" make-flags))) + (alist-replace + 'configure + ;; bitlbee's configure script does not tolerate many of the + ;; variable settings that Guix would pass to it. + (lambda* (#:key outputs #:allow-other-keys) + (zero? (system* "./configure" + (string-append "--prefix=" + (assoc-ref outputs "out")) + "--otr=1"))) + %standard-phases)))) + (synopsis "IRC to instant messaging gateway") + (description "BitlBee brings IM (instant messaging) to IRC clients, for +people who have an IRC client running all the time and don't want to run an +additional IM client. BitlBee currently supports XMPP/Jabber (including +Google Talk), MSN Messenger, Yahoo! Messenger, AIM and ICQ, and the Twitter +microblogging network (plus all other Twitter API compatible services like +identi.ca and status.net).") + (home-page "http://www.bitlbee.org/") + (license (list gpl2+ bsd-2)))) + +;;; messaging.scm ends here diff --git a/gnu/packages/mpd.scm b/gnu/packages/mpd.scm index b2c5dec15b..04b34eaf87 100644 --- a/gnu/packages/mpd.scm +++ b/gnu/packages/mpd.scm @@ -29,13 +29,15 @@ #:use-module (gnu packages glib) #:use-module (gnu packages linux) #:use-module (gnu packages mp3) + #:use-module (gnu packages ncurses) #:use-module (gnu packages pkg-config) #:use-module (gnu packages pulseaudio) #:use-module (gnu packages sqlite) #:use-module (gnu packages video) #:use-module (gnu packages xiph) #:export (libmpdclient - mpd)) + mpd + ncmpc)) (define libmpdclient (package @@ -121,3 +123,27 @@ can play a variety of sound files while being controlled by its network protocol.") (home-page "http://www.musicpd.org/") (license license:gpl2))) + +(define ncmpc + (package + (name "ncmpc") + (version "0.21") + (source (origin + (method url-fetch) + (uri + (string-append "http://musicpd.org/download/ncmpc/" + (car (string-split version #\.)) + "/ncmpc-" version ".tar.gz")) + (sha256 + (base32 + "1gpy6rr0awl6xgkswmr8rdvqfkrz83rmwk441c00a9d4z3zb1a16")))) + (build-system gnu-build-system) + (inputs `(("glib" ,glib) + ("libmpdclient" ,libmpdclient) + ("ncurses" ,ncurses))) + (native-inputs `(("pkg-config" ,pkg-config))) + (synopsis "A curses Music Player Daemon client") + (description "ncmpc is a fully featured MPD client, which runs in a +terminal using ncurses.") + (home-page "http://www.musicpd.org/clients/ncmpc/") + (license license:gpl2))) diff --git a/gnu/packages/patches/bitlbee-fix-tests.patch b/gnu/packages/patches/bitlbee-fix-tests.patch new file mode 100644 index 0000000000..52bb6c605d --- /dev/null +++ b/gnu/packages/patches/bitlbee-fix-tests.patch @@ -0,0 +1,33 @@ +Pass the correct number of arguments to 'nick_strip' and 'nick_ok' in tests. + +Patch by Mark H Weaver <mhw@netris.org>. + +--- bitlbee/tests/check_nick.c.orig 2013-11-27 17:54:54.000000000 -0500 ++++ bitlbee/tests/check_nick.c 2014-03-05 23:41:45.761230468 -0500 +@@ -30,7 +30,7 @@ START_TEST(test_nick_strip) + for (i = 0; get[i]; i++) { + char copy[60]; + strcpy(copy, get[i]); +- nick_strip(copy); ++ nick_strip(NULL, copy); + fail_unless (strcmp(copy, expected[i]) == 0, + "(%d) nick_strip broken: %s -> %s (expected: %s)", + i, get[i], copy, expected[i]); +@@ -45,7 +45,7 @@ START_TEST(test_nick_ok_ok) + int i; + + for (i = 0; nicks[i]; i++) { +- fail_unless (nick_ok(nicks[i]) == 1, ++ fail_unless (nick_ok(NULL, nicks[i]) == 1, + "nick_ok() failed: %s", nicks[i]); + } + } +@@ -58,7 +58,7 @@ START_TEST(test_nick_ok_notok) + int i; + + for (i = 0; nicks[i]; i++) { +- fail_unless (nick_ok(nicks[i]) == 0, ++ fail_unless (nick_ok(NULL, nicks[i]) == 0, + "nick_ok() succeeded for invalid: %s", nicks[i]); + } + } diff --git a/gnu/packages/patches/bitlbee-memset-fix.patch b/gnu/packages/patches/bitlbee-memset-fix.patch new file mode 100644 index 0000000000..1d801e0070 --- /dev/null +++ b/gnu/packages/patches/bitlbee-memset-fix.patch @@ -0,0 +1,15 @@ +Fix the size argument to 'memset'. + +Patch by Mark H Weaver <mhw@netris.org>. + +--- bitlbee/lib/md5.c.orig 2013-11-27 17:54:54.000000000 -0500 ++++ bitlbee/lib/md5.c 2014-03-05 21:39:04.739746093 -0500 +@@ -159,7 +159,7 @@ void md5_finish(struct MD5Context *ctx, + ctx->buf[2] = cvt32(ctx->buf[2]); + ctx->buf[3] = cvt32(ctx->buf[3]); + memcpy(digest, ctx->buf, 16); +- memset(ctx, 0, sizeof(ctx)); /* In case it's sensitive */ ++ memset(ctx, 0, sizeof(*ctx)); /* In case it's sensitive */ + } + + void md5_finish_ascii(struct MD5Context *context, char *ascii) diff --git a/gnu/packages/patches/source-highlight-regexrange-test.patch b/gnu/packages/patches/source-highlight-regexrange-test.patch new file mode 100644 index 0000000000..298c831b35 --- /dev/null +++ b/gnu/packages/patches/source-highlight-regexrange-test.patch @@ -0,0 +1,15 @@ +Disable a single check. The failure is discussed at: + + https://savannah.gnu.org/bugs/index.php?41786 + +--- a/lib/tests/test_regexranges_main.cpp 2012-04-14 08:58:25.000000000 -0500 ++++ b/lib/tests/test_regexranges_main.cpp 2014-03-05 23:49:23.520402043 -0600 +@@ -52,7 +52,7 @@ + check_range_regex("simple regex"); + check_range_regex("[[:alpha:]]+"); + // test with a wrong regular expression +- check_range_regex("{notclosed", false); ++ // check_range_regex("{notclosed", false); + + // reset regular expressions + ranges.clear(); diff --git a/gnu/packages/pretty-print.scm b/gnu/packages/pretty-print.scm new file mode 100644 index 0000000000..0bfbeb7229 --- /dev/null +++ b/gnu/packages/pretty-print.scm @@ -0,0 +1,224 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.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 packages pretty-print) + #:use-module (guix packages) + #:use-module (guix licenses) + #:use-module (guix download) + #:use-module (guix build-system gnu) + #:use-module (gnu packages) + #:use-module (gnu packages ghostscript) + #:use-module (gnu packages groff) + #:use-module (gnu packages imagemagick) + #:use-module (gnu packages gv) + #:use-module (gnu packages boost) + #:use-module (gnu packages bison) + #:use-module (gnu packages flex) + #:use-module (gnu packages gperf) + #:use-module (gnu packages perl) + #:use-module (gnu packages file)) + +(define-public a2ps + (package + (name "a2ps") + (version "4.14") + (source + (origin + (method url-fetch) + (uri (string-append "mirror://gnu/a2ps/a2ps-" + version ".tar.gz")) + (sha256 + (base32 + "195k78m1h03m961qn7jr120z815iyb93gwi159p1p9348lyqvbpk")))) + (build-system gnu-build-system) + (inputs + `(("psutils" ,psutils) + ("groff" ,groff) + ("gv" ,gv) + ("imagemagick" ,imagemagick))) + (native-inputs + `(("gperf" ,gperf) + ("perl" ,perl) + ("file" ,file))) + (arguments + '(#:phases (alist-replace + 'configure + (lambda* (#:key #:allow-other-keys #:rest args) + (let ((configure (assoc-ref %standard-phases 'configure))) + (substitute* "configure" + (("/usr/bin/file") (which "file"))) + (apply configure args))) + (alist-cons-before + 'build 'patch-scripts + (lambda _ + (substitute* + '("afm/make_fonts_map.sh" + "tests/defs" + "tests/backup.tst" + "tests/styles.tst") + (("/bin/rm") (which "rm")))) + (alist-cons-before + 'check 'patch-test-files + ;; Alternatively, we could unpatch the shebangs in tstfiles + (lambda* (#:key inputs #:allow-other-keys) + (let ((perl (assoc-ref inputs "perl"))) + (substitute* '("tests/ps-ref/includeres.ps" + "tests/gps-ref/includeres.ps") + (("/usr/local/bin/perl") + (string-append perl "/bin/perl")))) + ;; Some of the reference postscript contain a 'version 3' + ;; string that in inconsistent with the source text in the + ;; tstfiles directory. Erroneous search-and-replace? + (substitute* '("tests/ps-ref/InsertBlock.ps" + "tests/gps-ref/InsertBlock.ps" + "tests/ps-ref/bookie.ps" + "tests/gps-ref/bookie.ps") + (("version 3") "version 2")) + (substitute* '("tests/ps-ref/psmandup.ps" + "tests/gps-ref/psmandup.ps") + (("#! */bin/sh") (string-append + "#!" (which "sh"))))) + %standard-phases))))) + (home-page "http://www.gnu.org/software/a2ps") + (synopsis "Any file to PostScript, including pretty-printing") + (description + "GNU a2ps converts almost anything to a PostScript file, ready for +printing. It accomplishes this by being able to delegate files to external +handlers, such as Groff and Gzip. It handles as many steps as is necessary to +produce a pretty-printed file. It also includes some extra abilities for +special cases, such as pretty-printing \"--help\" output.") + (license gpl3+))) + +(define-public trueprint + (package + (name "trueprint") + (version "5.4") + (source + (origin + (method url-fetch) + (uri (string-append "mirror://gnu/trueprint/trueprint-" + version ".tar.gz")) + (sha256 + (base32 + "13rkc0fga10xyf56yy9dnq95zndnfadkhxflnp24skszj21y8jqh")))) + (build-system gnu-build-system) + (native-inputs `(("file" ,file))) + (arguments + ;; Must define DIFF_CMD for tests to pass + '(#:configure-flags '("CPPFLAGS=-DDIFF_CMD=\\\"diff\\\"") + #:phases (alist-replace + 'configure + (lambda* (#:key #:allow-other-keys #:rest args) + (let ((configure (assoc-ref %standard-phases 'configure))) + (substitute* "configure" + (("/usr/bin/file") (which "file"))) + (apply configure args))) + %standard-phases))) + (home-page "http://www.gnu.org/software/trueprint") + (synopsis "Pretty-print C sources and other plain text to PostScript") + (description + "GNU Trueprint translates C source code files as PostScript files. +In addition to the basic source code output, it can also perform diff-marking, +indentation counting, function and file indices and more.") + (license gpl2))) + +(define-public enscript + (package + (name "enscript") + (version "1.6.6") + (source + (origin + (method url-fetch) + (uri (string-append "mirror://gnu/enscript/enscript-" + version ".tar.gz")) + (sha256 + (base32 + "1fy0ymvzrrvs889zanxcaxjfcxarm2d3k43c9frmbl1ld7dblmkd")))) + (build-system gnu-build-system) + (home-page "http://www.gnu.org/software/enscript") + (synopsis "Generating PostScript, including pretty-printing") + (description + "GNU Enscript is a program to convert ASCII text files to PostScript, +HTML or RTF formats, to be stored in files or sent immediately to a printer. +It also includes the capability to perform syntax highlighting for several +different programming languages.") + (license gpl3+))) + +(define-public source-highlight + (package + (name "source-highlight") + (version "3.1.7") + (source + (origin + (method url-fetch) + (uri (string-append "mirror://gnu/src-highlite/source-highlight-" + version ".tar.gz")) + (sha256 + (base32 + "1s49ld8cnpzhhwq0r7s0sfm3cg3nhhm0wla27lwraifrrl3y1cp1")) + (patches + (list (search-patch + ;; Patch submitted as Savannah item #41786 + "source-highlight-regexrange-test.patch"))))) + (build-system gnu-build-system) + ;; The ctags that comes with emacs does not support the --excmd options, + ;; so can't be used + (inputs + `(("boost" ,boost))) + (native-inputs + `(("bison" ,bison) + ("flex" ,flex) + ("file" ,file))) + (arguments + `(#:configure-flags + (list (string-append "--with-boost=" + (assoc-ref %build-inputs "boost"))) + #:parallel-tests? #f ;There appear to be race conditions + #:phases (alist-replace + 'configure + (lambda* (#:key #:allow-other-keys #:rest args) + (let ((configure (assoc-ref %standard-phases 'configure))) + (substitute* "configure" + (("/usr/bin/file") (which "file"))) + (apply configure args))) + (alist-cons-before + 'check 'patch-test-files + (lambda* (#:key inputs #:allow-other-keys) + ;; Unpatch shebangs in test input so that source-highlight + ;; is still able to infer input language + (substitute* '("tests/test.sh" + "tests/test2.sh" + "tests/test.tcl") + (((string-append "#! *" (which "sh"))) "#!/bin/sh")) + ;; Initial patching unrecoverably removes whitespace, so + ;; remove it also in the comparison output. + (substitute* '("tests/test.sh.html" + "tests/test2.sh.html" + "tests/test.tcl.html") + (("#! */bin/sh") "#!/bin/sh"))) + %standard-phases)))) + (home-page "http://www.gnu.org/software/src-highlite") + (synopsis "Produce a document with syntax highlighting from a source file") + (description + "GNU source-highlight reads in a source code file and produces an output +file in which the keywords are highlighted in different colors to designate +their syntactic role. It supports over 150 different languages and it can +output to 8 different formats, including HTML, LaTeX and ODF. It can also +output to ANSI color escape sequences, so that highlighted source code can be +seen in a terminal.") + (license gpl3+))) diff --git a/gnu/packages/python.scm b/gnu/packages/python.scm index 44e3c14aa2..ad1ac5c8f7 100644 --- a/gnu/packages/python.scm +++ b/gnu/packages/python.scm @@ -20,7 +20,8 @@ (define-module (gnu packages python) #:use-module ((guix licenses) - #:select (bsd-3 bsd-style psfl x11 gpl2+ lgpl2.1+)) + #:select (bsd-3 bsd-style psfl x11 x11-style + gpl2 gpl2+ lgpl2.1+)) #:use-module ((guix licenses) #:select (zlib) #:renamer (symbol-prefix-proc 'license:)) #:use-module (gnu packages) @@ -505,6 +506,55 @@ system is highly configurable via command line options and embedded commands.") (license lgpl2.1+))) +(define-public python2-element-tree + (package + (name "python2-element-tree") + (version "1.2.6") + (source (origin + (method url-fetch) + (uri (string-append + "http://effbot.org/media/downloads/elementtree-" + version "-20050316.tar.gz")) + (sha256 + (base32 + "016bphqnlg0l4vslahhw4r0aanw95bpypy65r1i1acyb2wj5z7dj")))) + (build-system python-build-system) + (arguments + `(#:python ,python-2 ; seems to be part of Python 3 + #:tests? #f)) ; no 'test' sub-command + (synopsis "Toolkit for XML processing in Python") + (description + "ElementTree is a Python library supporting lightweight XML processing.") + (home-page "http://effbot.org/zone/element-index.htm") + (license (x11-style "http://docs.python.org/2/license.html" + "Like \"CWI LICENSE AGREEMENT FOR PYTHON \ +0.9.0 THROUGH 1.2\".")))) + +(define-public python2-pybugz + (package + (name "python2-pybugz") + (version "0.6.11") + (source (origin + (method url-fetch) + (uri (string-append + "http://bits.liquidx.net/projects/pybugz/pybugz-" + version ".tar.gz")) + (sha256 + (base32 + "17ni00p08gp5lkxlrrcnvi3x09fmajnlbz4da03qcgl9q21ym4jd")))) + (build-system python-build-system) + (arguments + `(#:python ,python-2 ; SyntaxError with Python 3 + #:tests? #f)) ; no 'test' sub-command + (inputs `(("element-tree" ,python2-element-tree))) + (synopsis "Python and command-line interface to Bugzilla") + (description + "PyBugz is a Python library and command-line tool to query the Bugzilla +bug tracking system. It is meant as an aid to speed up interaction with the +bug tracker.") + (home-page "http://www.liquidx.net/pybugz/") + (license gpl2))) + (define-public scons (package (name "scons") diff --git a/gnu/packages/rdf.scm b/gnu/packages/rdf.scm index 1f2bc7932d..22cfc2e257 100644 --- a/gnu/packages/rdf.scm +++ b/gnu/packages/rdf.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 Andreas Enge <andreas@enge.fr> +;;; Copyright © 2013, 2014 Andreas Enge <andreas@enge.fr> ;;; ;;; This file is part of GNU Guix. ;;; @@ -45,6 +45,8 @@ ("libxml2" ,libxml2) ("libxslt" ,libxslt) ("zlib" ,zlib))) + (arguments + `(#:parallel-tests? #f)) (home-page "http://librdf.org/raptor/") (synopsis "RDF syntax library") (description "Raptor is a C library providing a set of parsers and @@ -76,11 +78,12 @@ HTML and JSON.") (base32 "08gb5d8bgy7vc6qd6r1kkmmc5rli67dlglpjqjlahpnvs26r1cwl")))) (build-system cmake-build-system) - ;; FIXME: Add optional dependencies: Raptor, Redland, odbci, clucene; doxygen - (inputs - `(("qt" ,qt-4))) + ;; FIXME: Add optional dependencies: Redland, odbci, clucene; doxygen (native-inputs `(("pkg-config" ,pkg-config))) + (inputs + `(("qt" ,qt-4) + ("raptor2" ,raptor2))) (home-page "http://soprano.sourceforge.net/") (synopsis "RDF data library for Qt") (description "Soprano (formerly known as QRDF) is a library which diff --git a/gnu/packages/ssh.scm b/gnu/packages/ssh.scm index 41ceeb6cef..6bf68a916e 100644 --- a/gnu/packages/ssh.scm +++ b/gnu/packages/ssh.scm @@ -27,6 +27,7 @@ #:use-module (gnu packages guile) #:use-module (gnu packages pkg-config) #:use-module (gnu packages autotools) + #:use-module (gnu packages texinfo) #:use-module (gnu packages which) #:use-module (guix packages) #:use-module (guix download) @@ -185,7 +186,7 @@ Additionally, various channel-specific options can be negotiated.") (define-public guile-ssh (package (name "guile-ssh") - (version "0.4.0") + (version "0.5.0") (source (origin (method url-fetch) (uri (string-append @@ -193,13 +194,13 @@ Additionally, various channel-specific options can be negotiated.") version ".tar.gz")) (sha256 (base32 - "0vw02r261amkp6238cflww2y9y1v6vfx9ias6hvn8dlx0ghrd5dw")))) + "13wk2fj08b8zjylvf78l3d9pf8y3zqcd7h75jf15a46iprk00n7q")))) (build-system gnu-build-system) (arguments '(#:phases (alist-cons-before 'configure 'autoreconf (lambda* (#:key inputs #:allow-other-keys) - (substitute* "src/Makefile.am" + (substitute* "ssh/Makefile.am" (("-lssh_threads" match) (string-append "-L" (assoc-ref inputs "libssh") "/lib " match))) @@ -223,10 +224,17 @@ Additionally, various channel-specific options can be negotiated.") %standard-phases)) #:configure-flags (list (string-append "--with-guilesitedir=" (assoc-ref %outputs "out") - "/share/guile/site/2.0")))) + "/share/guile/site/2.0")) + + ;; Two client/server tests use the same port. + #:parallel-tests? #f + + ;; XXX: There are test failures reported and being fixed. + #:tests? #f)) (native-inputs `(("autoconf" ,autoconf) ("automake" ,automake) ("libtool" ,libtool "bin") + ("texinfo" ,texinfo) ("pkg-config" ,pkg-config) ("which" ,which))) (inputs `(("guile" ,guile-2.0) diff --git a/gnu/packages/version-control.scm b/gnu/packages/version-control.scm index 3d69eee5cd..41df90b8a7 100644 --- a/gnu/packages/version-control.scm +++ b/gnu/packages/version-control.scm @@ -2,7 +2,7 @@ ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2013 Cyril Roelandt <tipecaml@gmail.com> ;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> -;;; Copyright © 2013 Andreas Enge <andreas@enge.fr> +;;; Copyright © 2013, 2014 Andreas Enge <andreas@enge.fr> ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,13 +26,15 @@ #:use-module (guix build-system gnu) #:use-module (guix build-system python) #:use-module (guix build utils) - #:use-module (gnu packages gettext) #:use-module (gnu packages apr) #:use-module (gnu packages curl) #:use-module (gnu packages ed) + #:use-module (gnu packages gettext) +;; #:use-module (gnu packages gnutls) #:use-module (gnu packages nano) #:use-module (gnu packages openssl) #:use-module (gnu packages perl) + #:use-module (gnu packages pkg-config) #:use-module (gnu packages python) #:use-module (gnu packages sqlite) #:use-module (gnu packages admin) @@ -216,17 +218,77 @@ It efficiently handles projects of any size and offers an easy and intuitive interface.") (license gpl2+))) +(define-public neon + (package + (name "neon") + (version "0.30.0") + (source (origin + (method url-fetch) + (uri (string-append "http://www.webdav.org/neon/neon-" + version ".tar.gz")) + (sha256 + (base32 + "1hlhg5w505jxdvaf7bq17057f6a48dry981g7lp2gwrhbp5wyqi9")))) + (build-system gnu-build-system) + (native-inputs + `(("perl" ,perl) + ("pkg-config" ,pkg-config))) + (inputs + `(("libxml2" ,libxml2) + ("openssl" ,openssl) + ("zlib" ,zlib))) + (arguments + `(;; FIXME: Add tests once reverse address lookup is fixed in glibc, see + ;; https://sourceware.org/bugzilla/show_bug.cgi?id=16475 + #:tests? #f + #:configure-flags '("--enable-shared" + ;; requires libgnutils-config, deprecated + ;; in gnutls 2.8. + ; "--with-ssl=gnutls"))) + "--with-ssl=openssl"))) + (home-page "http://www.webdav.org/neon/") + (synopsis "HTTP and WebDAV client library") + (description "Neon is an HTTP and WebDAV client library, with a +C interface. Features: +High-level wrappers for common HTTP and WebDAV operations (GET, MOVE, +DELETE, etc.); +low-level interface to the HTTP request/response engine, allowing the use +of arbitrary HTTP methods, headers, etc.; +authentication support including Basic and Digest support, along with +GSSAPI-based Negotiate on Unix, and SSPI-based Negotiate/NTLM on Win32; +SSL/TLS support using OpenSSL or GnuTLS, exposing an abstraction layer for +verifying server certificates, handling client certificates, and examining +certificate properties, smartcard-based client certificates are also +supported via a PKCS#11 wrapper interface; +abstract interface to parsing XML using libxml2 or expat, and wrappers for +simplifying handling XML HTTP response bodies; +WebDAV metadata support, wrappers for PROPFIND and PROPPATCH to simplify +property manipulation.") + (license gpl2+))) ; for documentation and tests; source under lgpl2.0+ + +(define-public neon-0.29.6 + (package (inherit neon) + (name "neon") + (version "0.29.6") + (source (origin + (method url-fetch) + (uri (string-append "http://www.webdav.org/neon/neon-" + version ".tar.gz")) + (sha256 + (base32 + "0hzbjqdx1z8zw0vmbknf159wjsxbcq8ii0wgwkqhxj3dimr0nr4w")))))) + (define-public subversion (package (name "subversion") - (version "1.7.8") + (version "1.7.14") (source (origin (method url-fetch) (uri (string-append "http://archive.apache.org/dist/subversion/subversion-" version ".tar.bz2")) (sha256 (base32 - "11inl9n1riahfnbk1fax0dysm2swakzhzhpmm2zvga6fikcx90zw")))) + "038jbcpwm083abp0rvk0fhnx65kp9mz1qvzs3f83ig8fxcvqzb64")))) (build-system gnu-build-system) (arguments '(#:phases (alist-cons-after @@ -250,11 +312,13 @@ and offers an easy and intuitive interface.") (system* "make" "install"))))))) %standard-phases))) (native-inputs - ;; For the Perl bindings. - `(("swig" ,swig))) + `(("pkg-config" ,pkg-config) + ;; For the Perl bindings. + ("swig" ,swig))) (inputs `(("apr" ,apr) ("apr-util" ,apr-util) + ("neon" ,neon-0.29.6) ("perl" ,perl) ("python" ,python-2) ; incompatible with Python 3 (print syntax) ("sqlite" ,sqlite) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index b8b0274f1f..b6a777353f 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -383,7 +383,13 @@ such as /etc files." (system* grub "--no-floppy" "--boot-directory" "/fs/boot" "/dev/sda")) - (zero? (system* umount "/fs")) + (begin + (when (file-exists? "/fs/dev/pts") + ;; Unmount devpts so /fs itself can be + ;; unmounted (failing to do that leads to + ;; EBUSY.) + (system* umount "/fs/dev/pts")) + (zero? (system* umount "/fs"))) (reboot)))))))) #:system system #:inputs `(("parted" ,parted) diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 80ce679496..9a8ea0ed4f 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -114,6 +114,14 @@ (device-number 4 n)) (loop (+ 1 n))))) + ;; Pseudo ttys. + (mknod (scope "dev/ptmx") 'char-special #o666 + (device-number 5 2)) + + (unless (file-exists? (scope "dev/pts")) + (mkdir (scope "dev/pts"))) + (mount "none" (scope "dev/pts") "devpts") + ;; Rendez-vous point for syslogd. (mknod (scope "dev/log") 'socket #o666 0) (mknod (scope "dev/kmsg") 'char-special #o600 (device-number 1 11)) diff --git a/guix/config.scm.in b/guix/config.scm.in index 5edb4ced30..eaadae9618 100644 --- a/guix/config.scm.in +++ b/guix/config.scm.in @@ -57,7 +57,7 @@ (define %state-directory ;; This must match `NIX_STATE_DIR' as defined in `daemon.am'. - (or (getenv "NIX_STATE_DIR") "@guix_localstatedir@/nix")) + (or (getenv "NIX_STATE_DIR") "@guix_localstatedir@/guix")) (define %config-directory ;; This must match `NIX_CONF_DIR' as defined in `daemon.am'. diff --git a/guix/download.scm b/guix/download.scm index 2cc8a4a5b8..0889928d3a 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -242,7 +242,11 @@ must be a list of symbol/URL-list pairs." (guix build utils) (guix ftp-client)) #:guile-for-build guile-for-build - #:env-vars env-vars))) + #:env-vars env-vars + + ;; In general, offloading downloads is not a + ;; good idea. + #:local-build? #t))) (define* (download-to-store store url #:optional (name (basename url)) #:key (log (current-error-port))) diff --git a/guix/git-download.scm b/guix/git-download.scm index 472bf756ce..5e0a6a21dc 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -84,6 +84,7 @@ type HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #:recursive? #t #:modules '((guix build git) (guix build utils)) - #:guile-for-build guile-for-build))) + #:guile-for-build guile-for-build + #:local-build? #t))) ;;; git-download.scm ends here diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 98432a69ce..14195da7ba 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2010, 2011, 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2010, 2011, 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; ;;; This file is part of GNU Guix. @@ -275,6 +275,10 @@ open (resp. close) FTP connections; this can be useful to reuse connections." (define contains-digit? (cut string-any char-set:digit <>)) + (define patch-directory-name? + ;; Return #t for patch directory names such as 'bash-4.2-patches'. + (cut string-suffix? "patches" <>)) + (let-values (((server directory) (ftp-server/directory project))) (define conn (ftp-open server)) @@ -284,6 +288,9 @@ open (resp. close) FTP connections; this can be useful to reuse connections." ;; Filter out sub-directories that do not contain digits---e.g., ;; /gnuzilla/lang and /gnupg/patches. (subdirs (filter-map (match-lambda + (((? patch-directory-name? dir) + 'directory . _) + #f) (((? contains-digit? dir) 'directory . _) dir) (_ #f)) diff --git a/guix/http-client.scm b/guix/http-client.scm index 11231cbc1e..1f05df4b05 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2012 Free Software Foundation, Inc. ;;; ;;; This file is part of GNU Guix. @@ -23,19 +23,36 @@ #:use-module (web client) #:use-module (web response) #:use-module (srfi srfi-11) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (rnrs io ports) #:use-module (rnrs bytevectors) #:use-module (guix ui) #:use-module (guix utils) - #:export (open-socket-for-uri + #:export (&http-get-error + http-get-error? + http-get-error-uri + http-get-error-code + http-get-error-reason + + open-socket-for-uri http-fetch)) ;;; Commentary: ;;; -;;; HTTP client portable among Guile versions. +;;; HTTP client portable among Guile versions, and with proper error condition +;;; reporting. ;;; ;;; Code: +;; HTTP GET error. +(define-condition-type &http-get-error &error + http-get-error? + (uri http-get-error-uri) ; URI + (code http-get-error-code) ; integer + (reason http-get-error-reason)) ; string + + (define-syntax when-guile<=2.0.5 (lambda (s) (syntax-case s () @@ -154,7 +171,9 @@ unbuffered." "Return an input port containing the data at URI, and the expected number of bytes available or #f. If TEXT? is true, the data at URI is considered to be textual. Follow any HTTP redirection. When BUFFERED? is #f, return an -unbuffered port, suitable for use in `filtered-port'." +unbuffered port, suitable for use in `filtered-port'. + +Raise an '&http-get-error' condition if downloading fails." (let loop ((uri uri)) (let ((port (or port (open-socket-for-uri uri @@ -202,7 +221,11 @@ unbuffered port, suitable for use in `filtered-port'." (uri->string uri)) (loop uri))) (else - (error "download failed" uri code - (response-reason-phrase resp)))))))) + (raise (condition (&http-get-error + (uri uri) + (code code) + (reason (response-reason-phrase resp))) + (&message + (message "download failed")))))))))) ;;; http-client.scm ends here diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 4788468584..8280a821c5 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -64,6 +64,9 @@ Export/import one or more packages from/to the store.\n")) --generate-key[=PARAMETERS] generate a key pair with the given parameters")) (display (_ " + --authorize authorize imports signed by the public key on stdin")) + (newline) + (display (_ " -e, --expression=EXPR build the package or derivation EXPR evaluates to")) (display (_ " -S, --source build the packages' source derivations")) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 4a00505022..618015e9ba 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -127,6 +127,8 @@ options handled by 'set-build-options-from-command-line', and listed in --max-silent-time=SECONDS mark the build as failed after SECONDS of silence")) (display (_ " + --timeout=SECONDS mark the build as failed after SECONDS of activity")) + (display (_ " --verbosity=LEVEL use the given verbosity LEVEL")) (display (_ " -c, --cores=N allow the use of up to N CPU cores for the build"))) @@ -142,39 +144,57 @@ options handled by 'set-build-options-from-command-line', and listed in #:use-substitutes? (assoc-ref opts 'substitutes?) #:use-build-hook? (assoc-ref opts 'build-hook?) #:max-silent-time (assoc-ref opts 'max-silent-time) + #:timeout (assoc-ref opts 'timeout) #:verbosity (assoc-ref opts 'verbosity))) (define %standard-build-options ;; List of standard command-line options for tools that build something. (list (option '(#\K "keep-failed") #f #f - (lambda (opt name arg result) - (alist-cons 'keep-failed? #t result))) + (lambda (opt name arg result . rest) + (apply values + (alist-cons 'keep-failed? #t result) + rest))) (option '("fallback") #f #f - (lambda (opt name arg result) - (alist-cons 'fallback? #t - (alist-delete 'fallback? result)))) + (lambda (opt name arg result . rest) + (apply values + (alist-cons 'fallback? #t + (alist-delete 'fallback? result)) + rest))) (option '("no-substitutes") #f #f - (lambda (opt name arg result) - (alist-cons 'substitutes? #f - (alist-delete 'substitutes? result)))) + (lambda (opt name arg result . rest) + (apply values + (alist-cons 'substitutes? #f + (alist-delete 'substitutes? result)) + rest))) (option '("no-build-hook") #f #f - (lambda (opt name arg result) - (alist-cons 'build-hook? #f - (alist-delete 'build-hook? result)))) + (lambda (opt name arg result . rest) + (apply values + (alist-cons 'build-hook? #f + (alist-delete 'build-hook? result)) + rest))) (option '("max-silent-time") #t #f - (lambda (opt name arg result) - (alist-cons 'max-silent-time (string->number* arg) - result))) + (lambda (opt name arg result . rest) + (apply values + (alist-cons 'max-silent-time (string->number* arg) + result) + rest))) + (option '("timeout") #t #f + (lambda (opt name arg result . rest) + (apply values + (alist-cons 'timeout (string->number* arg) result) + rest))) (option '("verbosity") #t #f - (lambda (opt name arg result) + (lambda (opt name arg result . rest) (let ((level (string->number arg))) - (alist-cons 'verbosity level - (alist-delete 'verbosity result))))) + (apply values + (alist-cons 'verbosity level + (alist-delete 'verbosity result)) + rest)))) (option '(#\c "cores") #t #f - (lambda (opt name arg result) + (lambda (opt name arg result . rest) (let ((c (false-if-exception (string->number arg)))) (if c - (alist-cons 'cores c result) + (apply values (alist-cons 'cores c result) rest) (leave (_ "~a: not a number~%") arg))))))) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 00a145e5e9..4d2f78f711 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -23,7 +23,7 @@ #:use-module (guix derivations) #:use-module (guix nar) #:use-module (guix utils) - #:use-module ((guix build utils) #:select (which)) + #:use-module ((guix build utils) #:select (which mkdir-p)) #:use-module (guix ui) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -122,38 +122,40 @@ determined." (leave (_ "failed to load machine file '~a': ~s~%") file args)))))) -(define (open-ssh-gateway machine) - "Initiate an SSH connection gateway to MACHINE, and return the PID of the -running lsh gateway upon success, or #f on failure." - (catch 'system-error - (lambda () - (let* ((port (open-pipe* OPEN_READ %lsh-command - "-l" (build-machine-user machine) - "-i" (build-machine-private-key machine) - ;; XXX: With lsh 2.1, passing '--write-pid' - ;; last causes the PID not to be printed. - "--write-pid" "--gateway" "--background" "-z" - (build-machine-name machine))) - (line (read-line port)) - (status (close-pipe port))) - (if (zero? status) - (let ((pid (string->number line))) - (if (integer? pid) - pid - (begin - (warning (_ "'~a' did not write its PID on stdout: ~s~%") - %lsh-command line) - #f))) - (begin - (warning (_ "failed to initiate SSH connection to '~a':\ - '~a' exited with ~a~%") - (build-machine-name machine) - %lsh-command - (status:exit-val status)) - #f)))) - (lambda args - (leave (_ "failed to execute '~a': ~a~%") - %lsh-command (strerror (system-error-errno args)))))) +;;; FIXME: The idea was to open the connection to MACHINE once for all, but +;;; lshg is currently non-functional. +;; (define (open-ssh-gateway machine) +;; "Initiate an SSH connection gateway to MACHINE, and return the PID of the +;; running lsh gateway upon success, or #f on failure." +;; (catch 'system-error +;; (lambda () +;; (let* ((port (open-pipe* OPEN_READ %lsh-command +;; "-l" (build-machine-user machine) +;; "-i" (build-machine-private-key machine) +;; ;; XXX: With lsh 2.1, passing '--write-pid' +;; ;; last causes the PID not to be printed. +;; "--write-pid" "--gateway" "--background" "-z" +;; (build-machine-name machine))) +;; (line (read-line port)) +;; (status (close-pipe port))) +;; (if (zero? status) +;; (let ((pid (string->number line))) +;; (if (integer? pid) +;; pid +;; (begin +;; (warning (_ "'~a' did not write its PID on stdout: ~s~%") +;; %lsh-command line) +;; #f))) +;; (begin +;; (warning (_ "failed to initiate SSH connection to '~a':\ +;; '~a' exited with ~a~%") +;; (build-machine-name machine) +;; %lsh-command +;; (status:exit-val status)) +;; #f)))) +;; (lambda args +;; (leave (_ "failed to execute '~a': ~a~%") +;; %lsh-command (strerror (system-error-errno args)))))) (define (remote-pipe machine mode command) "Run COMMAND on MACHINE, assuming an lsh gateway has been set up." @@ -161,6 +163,10 @@ running lsh gateway upon success, or #f on failure." (lambda () (apply open-pipe* mode %lshg-command "-l" (build-machine-user machine) "-z" + + ;; XXX: Remove '-i' when %LSHG-COMMAND really is lshg. + "-i" (build-machine-private-key machine) + (build-machine-name machine) command)) (lambda args @@ -168,9 +174,89 @@ running lsh gateway upon success, or #f on failure." %lshg-command (strerror (system-error-errno args))) #f))) + +;;; +;;; Synchronization. +;;; + +(define (lock-file file) + "Wait and acquire an exclusive lock on FILE. Return an open port." + (mkdir-p (dirname file)) + (let ((port (open-file file "w0"))) + (fcntl-flock port 'write-lock) + port)) + +(define (unlock-file lock) + "Unlock LOCK." + (fcntl-flock lock 'unlock) + (close-port lock) + #t) + +(define-syntax-rule (with-file-lock file exp ...) + "Wait to acquire a lock on FILE and evaluate EXP in that context." + (let ((port (lock-file file))) + (dynamic-wind + (lambda () + #t) + (lambda () + exp ...) + (lambda () + (unlock-file port))))) + +(define-syntax-rule (with-machine-lock machine hint exp ...) + "Wait to acquire MACHINE's exclusive lock for HINT, and evaluate EXP in that +context." + (with-file-lock (machine-lock-file machine hint) + exp ...)) + + +(define (machine-slot-file machine slot) + "Return the file name of MACHINE's file for SLOT." + ;; For each machine we have a bunch of files representing each build slot. + ;; When choosing a build machine, we attempt to get an exclusive lock on one + ;; of these; if we fail, that means all the build slots are already taken. + ;; Inspired by Nix's build-remote.pl. + (string-append (string-append %state-directory "/offload/" + (build-machine-name machine) + "/" (number->string slot)))) + +(define (acquire-build-slot machine) + "Attempt to acquire a build slot on MACHINE. Return the port representing +the slot, or #f if none is available. + +This mechanism allows us to set a hard limit on the number of simultaneous +connections allowed to MACHINE." + (mkdir-p (dirname (machine-slot-file machine 0))) + (with-machine-lock machine 'slots + (any (lambda (slot) + (let ((port (open-file (machine-slot-file machine slot) + "w0"))) + (catch 'flock-error + (lambda () + (fcntl-flock port 'write-lock #:wait? #f) + ;; Got it! + (format (current-error-port) + "process ~a acquired build slot '~a'~%" + (getpid) (port-filename port)) + port) + (lambda args + ;; PORT is already locked by another process. + (close-port port) + #f)))) + (iota (build-machine-parallel-builds machine))))) + +(define (release-build-slot slot) + "Release SLOT, a build slot as returned as by 'acquire-build-slot'." + (close-port slot)) + + +;;; +;;; Offloading. +;;; + (define* (offload drv machine #:key print-build-trace? (max-silent-time 3600) - (build-timeout 7200) (log-port (current-output-port))) + build-timeout (log-port (current-output-port))) "Perform DRV on MACHINE, assuming DRV and its prerequisites are available there, and write the build log to LOG-PORT. Return the exit status." (format (current-error-port) "offloading '~a' to '~a'...~%" @@ -181,9 +267,12 @@ there, and write the build log to LOG-PORT. Return the exit status." ;; FIXME: Protect DRV from garbage collection on MACHINE. (let ((pipe (remote-pipe machine OPEN_READ `("guix" "build" - ;; FIXME: more options ,(format #f "--max-silent-time=~a" max-silent-time) + ,@(if build-timeout + (list (format #f "--timeout=~a" + build-timeout)) + '()) ,(derivation-file-name drv))))) (let loop ((line (read-line pipe))) (unless (eof-object? line) @@ -193,6 +282,43 @@ there, and write the build log to LOG-PORT. Return the exit status." (close-pipe pipe))) +(define* (transfer-and-offload drv machine + #:key + (inputs '()) + (outputs '()) + (max-silent-time 3600) + build-timeout + print-build-trace?) + "Offload DRV to MACHINE. Prior to the actual offloading, transfer all of +INPUTS to MACHINE; if building DRV succeeds, retrieve all of OUTPUTS from +MACHINE." + ;; Acquire MACHINE's exclusive lock to serialize file transfers + ;; to/from MACHINE in the presence of several 'offload' hook + ;; instance. + (when (with-machine-lock machine 'bandwidth + (send-files (cons (derivation-file-name drv) inputs) + machine)) + (let ((status (offload drv machine + #:print-build-trace? print-build-trace? + #:max-silent-time max-silent-time + #:build-timeout build-timeout))) + (if (zero? status) + (begin + ;; Likewise (see above.) + (with-machine-lock machine 'bandwidth + (retrieve-files outputs machine)) + (format (current-error-port) + "done with offloaded '~a'~%" + (derivation-file-name drv))) + (begin + (format (current-error-port) + "derivation '~a' offloaded to '~a' failed \ +with exit code ~a~%" + (derivation-file-name drv) + (build-machine-name machine) + (status:exit-val status)) + (primitive-exit (status:exit-val status))))))) + (define (send-files files machine) "Send the subset of FILES that's missing to MACHINE's store. Return #t on success, #f otherwise." @@ -256,6 +382,11 @@ success, #f otherwise." (zero? (close-pipe pipe))))))) + +;;; +;;; Scheduling. +;;; + (define (machine-matches? machine requirements) "Return #t if MACHINE matches REQUIREMENTS." (and (string=? (build-requirements-system requirements) @@ -268,57 +399,124 @@ success, #f otherwise." "Return #t if M1 is faster than M2." (> (build-machine-speed m1) (build-machine-speed m2))) -(define (choose-build-machine requirements machines) - "Return the best machine among MACHINES fulfilling REQUIREMENTS, or #f." - ;; FIXME: Take machine load into account, and/or shuffle MACHINES. - (let ((machines (sort (filter (cut machine-matches? <> requirements) - machines) - machine-faster?))) - (match machines - ((head . _) - head) - (_ #f)))) +(define (machine-load machine) + "Return the load of MACHINE, divided by the number of parallel builds +allowed on MACHINE." + (let* ((pipe (remote-pipe machine OPEN_READ `("cat" "/proc/loadavg"))) + (line (read-line pipe))) + (close-pipe pipe) + (if (eof-object? line) + 1. + (match (string-tokenize line) + ((one five fifteen . _) + (let* ((raw (string->number five)) + (jobs (build-machine-parallel-builds machine)) + (normalized (/ raw jobs))) + (format (current-error-port) "load on machine '~a' is ~s\ + (normalized: ~s)~%" + (build-machine-name machine) raw normalized) + normalized)) + (_ + 1.))))) + +(define (machine-less-loaded? m1 m2) + "Return #t if the load on M1 is lower than that on M2." + (< (machine-load m1) (machine-load m2))) + +(define (machine-less-loaded-or-faster? m1 m2) + "Return #t if M1 is either less loaded or faster than M2." + (or (machine-less-loaded? m1 m2) + (machine-faster? m1 m2))) + +(define (machine-lock-file machine hint) + "Return the name of MACHINE's lock file for HINT." + (string-append %state-directory "/offload/" + (build-machine-name machine) + "." (symbol->string hint) ".lock")) + +(define (machine-choice-lock-file) + "Return the name of the file used as a lock when choosing a build machine." + (string-append %state-directory "/offload/machine-choice.lock")) + + +(define %slots + ;; List of acquired build slots (open ports). + '()) + +(define (choose-build-machine machines) + "Return the best machine among MACHINES, or #f." + + ;; Proceed like this: + ;; 1. Acquire the global machine-choice lock. + ;; 2. For all MACHINES, attempt to acquire a build slot, and filter out + ;; those machines for which we failed. + ;; 3. Choose the best machine among those that are left. + ;; 4. Release the previously-acquired build slots of the other machines. + ;; 5. Release the global machine-choice lock. + + (with-file-lock (machine-choice-lock-file) + (define machines+slots + (filter-map (lambda (machine) + (let ((slot (acquire-build-slot machine))) + (and slot (list machine slot)))) + machines)) + + (define (undecorate pred) + (match-lambda + ((machine slot) + (and (pred machine) + (list machine slot))))) + + (let ((machines+slots (sort machines+slots + (undecorate machine-less-loaded-or-faster?)))) + (match machines+slots + (((best slot) (others slots) ...) + ;; Release slots from the uninteresting machines. + (for-each release-build-slot slots) + + ;; Return the best machine unless it's already overloaded. + (if (< (machine-load best) 2.) + (begin + ;; Prevent SLOT from being GC'd. + (set! %slots (cons slot %slots)) + best) + (begin + (release-build-slot slot) + #f))) + (() #f))))) (define* (process-request wants-local? system drv features #:key print-build-trace? (max-silent-time 3600) - (build-timeout 7200)) + build-timeout) "Process a request to build DRV." - (let* ((local? (and wants-local? (string=? system (%current-system)))) - (reqs (build-requirements - (system system) - (features features))) - (machine (choose-build-machine reqs (build-machines)))) - (if machine - (match (open-ssh-gateway machine) - ((? integer? pid) - (display "# accept\n") - (let ((inputs (string-tokenize (read-line))) - (outputs (string-tokenize (read-line)))) - (when (send-files (cons (derivation-file-name drv) inputs) - machine) - (let ((status (offload drv machine - #:print-build-trace? print-build-trace? - #:max-silent-time max-silent-time - #:build-timeout build-timeout))) - (kill pid SIGTERM) - (if (zero? status) - (begin - (retrieve-files outputs machine) - (format (current-error-port) - "done with offloaded '~a'~%" - (derivation-file-name drv))) - (begin - (format (current-error-port) - "derivation '~a' offloaded to '~a' failed \ -with exit code ~a~%" - (derivation-file-name drv) - (build-machine-name machine) - (status:exit-val status)) - (primitive-exit (status:exit-val status)))))))) - (#f - (display "# decline\n"))) - (display "# decline\n")))) + (let* ((local? (and wants-local? (string=? system (%current-system)))) + (reqs (build-requirements + (system system) + (features features))) + (candidates (filter (cut machine-matches? <> reqs) + (build-machines)))) + (match candidates + (() + ;; We'll never be able to match REQS. + (display "# decline\n")) + ((_ ...) + (let ((machine (choose-build-machine candidates))) + (if machine + (begin + ;; Offload DRV to MACHINE. + (display "# accept\n") + (let ((inputs (string-tokenize (read-line))) + (outputs (string-tokenize (read-line)))) + (transfer-and-offload drv machine + #:inputs inputs + #:outputs outputs + #:max-silent-time max-silent-time + #:build-timeout build-timeout + #:print-build-trace? print-build-trace?))) + + ;; Not now, all the machines are busy. + (display "# postpone\n"))))))) (define-syntax-rule (with-nar-error-handling body ...) "Execute BODY with any &nar-error suitably reported to the user." @@ -388,4 +586,9 @@ This tool is meant to be used internally by 'guix-daemon'.\n")) (x (leave (_ "invalid arguments: ~{~s ~}~%") x)))) +;;; Local Variables: +;;; eval: (put 'with-machine-lock 'scheme-indent-function 2) +;;; eval: (put 'with-file-lock 'scheme-indent-function 1) +;;; End: + ;;; offload.scm ends here diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index d41a83de8a..6069b203de 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -26,6 +26,7 @@ #:use-module (guix profiles) #:use-module (guix utils) #:use-module (guix config) + #:use-module (guix scripts build) #:use-module ((guix build utils) #:select (directory-exists? mkdir-p)) #:use-module ((guix ftp-client) #:select (ftp-open)) #:use-module (ice-9 format) @@ -460,6 +461,7 @@ ENTRIES, a list of manifest entries, in the context of PROFILE." ;; Alist of default option values. `((profile . ,%current-profile) (max-silent-time . 3600) + (verbosity . 0) (substitutes? . #t))) (define (show-help) @@ -484,18 +486,9 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (display (_ " -d, --delete-generations[=PATTERN] delete generations matching PATTERN")) - (newline) (display (_ " -p, --profile=PROFILE use PROFILE instead of the user's default profile")) - (display (_ " - -n, --dry-run show what would be done without actually doing it")) - (display (_ " - --fallback fall back to building when the substituter fails")) - (display (_ " - --no-substitutes build instead of resorting to pre-built substitutes")) - (display (_ " - --max-silent-time=SECONDS - mark the build as failed after SECONDS of silence")) + (newline) (display (_ " --bootstrap use the bootstrap Guile to build the profile")) (display (_ " @@ -510,6 +503,8 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) -A, --list-available[=REGEXP] list available packages matching REGEXP")) (newline) + (show-build-options-help) + (newline) (display (_ " -h, --help display this help and exit")) (display (_ " @@ -519,107 +514,94 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (define %options ;; Specification of the command-line options. - (list (option '(#\h "help") #f #f - (lambda args - (show-help) - (exit 0))) - (option '(#\V "version") #f #f - (lambda args - (show-version-and-exit "guix package"))) - - (option '(#\i "install") #f #t - (lambda (opt name arg result arg-handler) - (let arg-handler ((arg arg) (result result)) - (values (if arg - (alist-cons 'install arg result) - result) - arg-handler)))) - (option '(#\e "install-from-expression") #t #f - (lambda (opt name arg result arg-handler) - (values (alist-cons 'install (read/eval-package-expression arg) - result) - #f))) - (option '(#\r "remove") #f #t - (lambda (opt name arg result arg-handler) - (let arg-handler ((arg arg) (result result)) - (values (if arg - (alist-cons 'remove arg result) - result) - arg-handler)))) - (option '(#\u "upgrade") #f #t - (lambda (opt name arg result arg-handler) - (let arg-handler ((arg arg) (result result)) - (values (alist-cons 'upgrade arg - ;; Delete any prior "upgrade all" - ;; command, or else "--upgrade gcc" - ;; would upgrade everything. - (delete '(upgrade . #f) result)) - arg-handler)))) - (option '("roll-back") #f #f - (lambda (opt name arg result arg-handler) - (values (alist-cons 'roll-back? #t result) - #f))) - (option '(#\l "list-generations") #f #t - (lambda (opt name arg result arg-handler) - (values (cons `(query list-generations ,(or arg "")) - result) - #f))) - (option '(#\d "delete-generations") #f #t - (lambda (opt name arg result arg-handler) - (values (alist-cons 'delete-generations (or arg "") - result) - #f))) - (option '("search-paths") #f #f - (lambda (opt name arg result arg-handler) - (values (cons `(query search-paths) result) - #f))) - (option '(#\p "profile") #t #f - (lambda (opt name arg result arg-handler) - (values (alist-cons 'profile arg - (alist-delete 'profile result)) - #f))) - (option '(#\n "dry-run") #f #f - (lambda (opt name arg result arg-handler) - (values (alist-cons 'dry-run? #t result) - #f))) - (option '("fallback") #f #f - (lambda (opt name arg result arg-handler) - (values (alist-cons 'fallback? #t - (alist-delete 'fallback? result)) - #f))) - (option '("no-substitutes") #f #f - (lambda (opt name arg result arg-handler) - (values (alist-cons 'substitutes? #f - (alist-delete 'substitutes? result)) - #f))) - (option '("max-silent-time") #t #f - (lambda (opt name arg result arg-handler) - (values (alist-cons 'max-silent-time (string->number* arg) - result) - #f))) - (option '("bootstrap") #f #f - (lambda (opt name arg result arg-handler) - (values (alist-cons 'bootstrap? #t result) - #f))) - (option '("verbose") #f #f - (lambda (opt name arg result arg-handler) - (values (alist-cons 'verbose? #t result) - #f))) - (option '(#\s "search") #t #f - (lambda (opt name arg result arg-handler) - (values (cons `(query search ,(or arg "")) - result) - #f))) - (option '(#\I "list-installed") #f #t - (lambda (opt name arg result arg-handler) - (values (cons `(query list-installed ,(or arg "")) - result) - #f))) - (option '(#\A "list-available") #f #t - (lambda (opt name arg result arg-handler) - (values (cons `(query list-available ,(or arg "")) - result) - #f))))) + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix package"))) + + (option '(#\i "install") #f #t + (lambda (opt name arg result arg-handler) + (let arg-handler ((arg arg) (result result)) + (values (if arg + (alist-cons 'install arg result) + result) + arg-handler)))) + (option '(#\e "install-from-expression") #t #f + (lambda (opt name arg result arg-handler) + (values (alist-cons 'install (read/eval-package-expression arg) + result) + #f))) + (option '(#\r "remove") #f #t + (lambda (opt name arg result arg-handler) + (let arg-handler ((arg arg) (result result)) + (values (if arg + (alist-cons 'remove arg result) + result) + arg-handler)))) + (option '(#\u "upgrade") #f #t + (lambda (opt name arg result arg-handler) + (let arg-handler ((arg arg) (result result)) + (values (alist-cons 'upgrade arg + ;; Delete any prior "upgrade all" + ;; command, or else "--upgrade gcc" + ;; would upgrade everything. + (delete '(upgrade . #f) result)) + arg-handler)))) + (option '("roll-back") #f #f + (lambda (opt name arg result arg-handler) + (values (alist-cons 'roll-back? #t result) + #f))) + (option '(#\l "list-generations") #f #t + (lambda (opt name arg result arg-handler) + (values (cons `(query list-generations ,(or arg "")) + result) + #f))) + (option '(#\d "delete-generations") #f #t + (lambda (opt name arg result arg-handler) + (values (alist-cons 'delete-generations (or arg "") + result) + #f))) + (option '("search-paths") #f #f + (lambda (opt name arg result arg-handler) + (values (cons `(query search-paths) result) + #f))) + (option '(#\p "profile") #t #f + (lambda (opt name arg result arg-handler) + (values (alist-cons 'profile arg + (alist-delete 'profile result)) + #f))) + (option '(#\n "dry-run") #f #f + (lambda (opt name arg result arg-handler) + (values (alist-cons 'dry-run? #t result) + #f))) + (option '("bootstrap") #f #f + (lambda (opt name arg result arg-handler) + (values (alist-cons 'bootstrap? #t result) + #f))) + (option '("verbose") #f #f + (lambda (opt name arg result arg-handler) + (values (alist-cons 'verbose? #t result) + #f))) + (option '(#\s "search") #t #f + (lambda (opt name arg result arg-handler) + (values (cons `(query search ,(or arg "")) + result) + #f))) + (option '(#\I "list-installed") #f #t + (lambda (opt name arg result arg-handler) + (values (cons `(query list-installed ,(or arg "")) + result) + #f))) + (option '(#\A "list-available") #f #t + (lambda (opt name arg result arg-handler) + (values (cons `(query list-available ,(or arg "")) + result) + #f))) + + %standard-build-options)) (define (options->installable opts manifest) "Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold', @@ -1052,13 +1034,7 @@ more information.~%")) (or (process-query opts) (with-error-handling (parameterize ((%store (open-connection))) - (set-build-options (%store) - #:print-build-trace #f - #:fallback? (assoc-ref opts 'fallback?) - #:use-substitutes? - (assoc-ref opts 'substitutes?) - #:max-silent-time - (assoc-ref opts 'max-silent-time)) + (set-build-options-from-command-line (%store) opts) (parameterize ((%guile-for-build (package-derivation (%store) diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index 3aaa1c4284..54f4aaa6c0 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -38,6 +38,7 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) #:use-module (web uri) #:use-module (guix http-client) #:export (guix-substitute-binary)) @@ -133,33 +134,38 @@ provide." (if buffered? "rb" "r0b")))) (values port (stat:size (stat port))))) ((http) - ;; On Guile 2.0.5, `http-fetch' fetches the whole thing at once. So - ;; honor TIMEOUT? to disable the timeout when fetching a nar. - ;; - ;; Test this with: - ;; sudo tc qdisc add dev eth0 root netem delay 1500ms - ;; and then cancel with: - ;; sudo tc qdisc del dev eth0 root - (let ((port #f)) - (with-timeout (if (or timeout? (guile-version>? "2.0.5")) - %fetch-timeout - 0) - (begin - (warning (_ "while fetching ~a: server is unresponsive~%") - (uri->string uri)) - (warning (_ "try `--no-substitutes' if the problem persists~%")) - - ;; Before Guile v2.0.9-39-gfe51c7b, EINTR was reported to the user, - ;; and thus PORT had to be closed and re-opened. This is not the - ;; case afterward. - (unless (or (guile-version>? "2.0.9") - (version>? (version) "2.0.9.39")) - (when port - (close-port port)))) - (begin - (when (or (not port) (port-closed? port)) - (set! port (open-socket-for-uri uri #:buffered? buffered?))) - (http-fetch uri #:text? #f #:port port))))))) + (guard (c ((http-get-error? c) + (leave (_ "download from '~a' failed: ~a, ~s~%") + (uri->string (http-get-error-uri c)) + (http-get-error-code c) + (http-get-error-reason c)))) + ;; On Guile 2.0.5, `http-fetch' fetches the whole thing at once. So + ;; honor TIMEOUT? to disable the timeout when fetching a nar. + ;; + ;; Test this with: + ;; sudo tc qdisc add dev eth0 root netem delay 1500ms + ;; and then cancel with: + ;; sudo tc qdisc del dev eth0 root + (let ((port #f)) + (with-timeout (if (or timeout? (guile-version>? "2.0.5")) + %fetch-timeout + 0) + (begin + (warning (_ "while fetching ~a: server is unresponsive~%") + (uri->string uri)) + (warning (_ "try `--no-substitutes' if the problem persists~%")) + + ;; Before Guile v2.0.9-39-gfe51c7b, EINTR was reported to the user, + ;; and thus PORT had to be closed and re-opened. This is not the + ;; case afterward. + (unless (or (guile-version>? "2.0.9") + (version>? (version) "2.0.9.39")) + (when port + (close-port port)))) + (begin + (when (or (not port) (port-closed? port)) + (set! port (open-socket-for-uri uri #:buffered? buffered?))) + (http-fetch uri #:text? #f #:port port)))))))) (define-record-type <cache> (%make-cache url store-directory wants-mass-query?) diff --git a/guix/serialization.scm b/guix/serialization.scm index 474dc69de5..284b174794 100644 --- a/guix/serialization.scm +++ b/guix/serialization.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,11 +22,13 @@ #:use-module (rnrs io ports) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (ice-9 match) #:export (write-int read-int write-long-long read-long-long write-padding write-string read-string read-latin1-string write-string-list read-string-list + write-string-pairs write-store-path read-store-path write-store-path-list read-store-path-list)) @@ -94,6 +96,14 @@ (write-int (length l) p) (for-each (cut write-string <> p) l)) +(define (write-string-pairs l p) + (write-int (length l) p) + (for-each (match-lambda + ((first . second) + (write-string first p) + (write-string second p))) + l)) + (define (read-string-list p) (let ((len (read-int p))) (unfold (cut >= <> len) diff --git a/guix/store.scm b/guix/store.scm index 54ed31cbbc..909ef195de 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -197,7 +197,7 @@ result)))))) (define-syntax write-arg - (syntax-rules (integer boolean file string string-list + (syntax-rules (integer boolean file string string-list string-pairs store-path store-path-list base16) ((_ integer arg p) (write-int arg p)) @@ -209,6 +209,8 @@ (write-string arg p)) ((_ string-list arg p) (write-string-list arg p)) + ((_ string-pairs arg p) + (write-string-pairs arg p)) ((_ store-path arg p) (write-store-path arg p)) ((_ store-path-list arg p) @@ -430,6 +432,7 @@ encoding conversion errors." #:key keep-failed? keep-going? fallback? (verbosity 0) (max-build-jobs (current-processor-count)) + timeout (max-silent-time 3600) (use-build-hook? #t) (build-verbosity 0) @@ -462,12 +465,11 @@ encoding conversion errors." (when (>= (nix-server-minor-version server) 10) (send (boolean use-substitutes?))) (when (>= (nix-server-minor-version server) 12) - (send (string-list (fold-right (lambda (pair result) - (match pair - ((h . t) - (cons* h t result)))) - '() - binary-caches)))) + (let ((pairs (if timeout + `(("build-timeout" . ,(number->string timeout)) + ,@binary-caches) + binary-caches))) + (send (string-pairs pairs)))) (let loop ((done? (process-stderr server))) (or done? (process-stderr server))))) @@ -734,8 +736,13 @@ is raised if the set of paths read from PORT is not signed (as per (define* (export-paths server paths port #:key (sign? #t)) "Export the store paths listed in PATHS to PORT, in topological order, signing them if SIGN? is true." + (define ordered + ;; Sort PATHS, but don't include their references. + (filter (cut member <> paths) + (topologically-sorted server paths))) + (let ((s (nix-server-socket server))) - (let loop ((paths (topologically-sorted server paths))) + (let loop ((paths ordered)) (match paths (() (write-int 0 port)) @@ -822,7 +829,7 @@ must be an absolute store file name, or a derivation file name." (cond ((derivation-path? file) (let* ((base (basename file)) (log (string-append (dirname %state-directory) ; XXX - "/log/nix/drvs/" + "/log/guix/drvs/" (string-take base 2) "/" (string-drop base 2))) (log.bz2 (string-append log ".bz2"))) diff --git a/guix/utils.scm b/guix/utils.scm index 5fda2116de..68329ec915 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -244,6 +244,13 @@ buffered data is lost." ((string-contains %host-type "linux") 7) ; *-linux-gnu (else 9)))) ; *-gnu* +(define F_SETLK + ;; Likewise: GNU/Hurd and SPARC use 8, while the others typically use 6. + (compile-time-value + (cond ((string-contains %host-type "sparc") 8) ; sparc-*-linux-gnu + ((string-contains %host-type "linux") 6) ; *-linux-gnu + (else 8)))) ; *-gnu* + (define F_xxLCK ;; The F_RDLCK, F_WRLCK, and F_UNLCK constants. (compile-time-value @@ -252,12 +259,30 @@ buffered data is lost." ((string-contains %host-type "linux") #(0 1 2)) ; *-linux-gnu (else #(1 2 3))))) ; *-gnu* +(define %libc-errno-pointer + ;; Glibc's 'errno' pointer. + (let ((errno-loc (dynamic-func "__errno_location" (dynamic-link)))) + (and errno-loc + (let ((proc (pointer->procedure '* errno-loc '()))) + (proc))))) + +(define (errno) + "Return the current errno." + ;; XXX: We assume that nothing changes 'errno' while we're doing all this. + ;; In particular, that means that no async must be running here. + (if %libc-errno-pointer + (let ((bv (pointer->bytevector %libc-errno-pointer (sizeof int)))) + (bytevector-sint-ref bv 0 (native-endianness) (sizeof int))) + 0)) + (define fcntl-flock (let* ((ptr (dynamic-func "fcntl" (dynamic-link))) (proc (pointer->procedure int ptr `(,int ,int *)))) - (lambda (fd-or-port operation) + (lambda* (fd-or-port operation #:key (wait? #t)) "Perform locking OPERATION on the file beneath FD-OR-PORT. OPERATION -must be a symbol, one of 'read-lock, 'write-lock, or 'unlock." +must be a symbol, one of 'read-lock, 'write-lock, or 'unlock. When WAIT? is +true, block until the lock is acquired; otherwise, thrown an 'flock-error' +exception if it's already taken." (define (operation->int op) (case op ((read-lock) (vector-ref F_xxLCK 0)) @@ -273,7 +298,9 @@ must be a symbol, one of 'read-lock, 'write-lock, or 'unlock." ;; XXX: 'fcntl' is a vararg function, but here we happily use the ;; standard ABI; crossing fingers. (let ((err (proc fd - F_SETLKW ; lock & wait + (if wait? + F_SETLKW ; lock & wait + F_SETLK) ; non-blocking attempt (make-c-struct %struct-flock (list (operation->int operation) SEEK_SET @@ -282,7 +309,7 @@ must be a symbol, one of 'read-lock, 'write-lock, or 'unlock." (or (zero? err) ;; Presumably we got EAGAIN or so. - (throw 'flock-error fd)))))) + (throw 'flock-error (errno))))))) ;;; diff --git a/tests/derivations.scm b/tests/derivations.scm index f31b00b8a2..e87662a198 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -446,6 +446,20 @@ (build-derivations store (list drv)) #f))) +(test-assert "build-expression->derivation and timeout" + (let* ((store (let ((s (open-connection))) + (set-build-options s #:timeout 1) + s)) + (builder '(begin (sleep 100) (mkdir %output) #t)) + (drv (build-expression->derivation store "slow" builder)) + (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)) + #f))) + (test-assert "build-expression->derivation and derivation-prerequisites-to-build" (let ((drv (build-expression->derivation %store "fail" #f))) ;; The only direct dependency is (%guile-for-build) and it's already diff --git a/tests/store.scm b/tests/store.scm index 7b0f3249d2..8a25c7353b 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -190,9 +190,18 @@ (s1 (topologically-sorted %store (list y))) (s2 (topologically-sorted %store (list c y))) (s3 (topologically-sorted %store (cons y (references %store y))))) - (and (equal? s1 (list w x a b c d y)) - (equal? s2 (list a b c w x d y)) - (lset= string=? s1 s3)))) + ;; The order in which 'references' returns the references of Y is + ;; unspecified, so accommodate. + (let* ((x-then-d? (equal? (references %store y) (list x d)))) + (and (equal? s1 + (if x-then-d? + (list w x a b c d y) + (list a b c d w x y))) + (equal? s2 + (if x-then-d? + (list a b c w x d y) + (list a b c d w x y))) + (lset= string=? s1 s3))))) (test-assert "log-file, derivation" (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '())) @@ -399,7 +408,9 @@ Deriver: ~a~%" files))))))) (test-assert "export/import paths, ensure topological order" - (let* ((file1 (add-text-to-store %store "foo" (random-text))) + (let* ((file0 (add-text-to-store %store "baz" (random-text))) + (file1 (add-text-to-store %store "foo" (random-text) + (list file0))) (file2 (add-text-to-store %store "bar" (random-text) (list file1))) (files (list file1 file2)) @@ -412,9 +423,10 @@ Deriver: ~a~%" (bytevector=? dump1 dump2) (let* ((source (open-bytevector-input-port dump1)) (imported (import-paths %store source))) + ;; DUMP1 should contain exactly FILE1 and FILE2, not FILE0. (and (equal? imported (list file1 file2)) (every file-exists? files) - (null? (references %store file1)) + (equal? (list file0) (references %store file1)) (equal? (list file1) (references %store file2))))))) (test-assert "import corrupt path" diff --git a/tests/utils.scm b/tests/utils.scm index b5706aa792..adac5d4381 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -27,6 +27,9 @@ #:use-module (rnrs io ports) #:use-module (ice-9 match)) +(define temp-file + (string-append "t-utils-" (number->string (getpid)))) + (test-begin "utils") (test-assert "bytevector->base16-string->bytevector" @@ -139,36 +142,88 @@ (append pids1 pids2))) (equal? (get-bytevector-all decompressed) data))))) -(test-equal "fcntl-flock" - 0 ; the child's exit status - (let ((file (open-input-file (search-path %load-path "guix.scm")))) - (fcntl-flock file 'read-lock) +(false-if-exception (delete-file temp-file)) +(test-equal "fcntl-flock wait" + 42 ; the child's exit status + (let ((file (open-file temp-file "w0"))) + ;; Acquire an exclusive lock. + (fcntl-flock file 'write-lock) (match (primitive-fork) (0 (dynamic-wind (const #t) (lambda () - ;; Taking a read lock should be OK. - (fcntl-flock file 'read-lock) - (fcntl-flock file 'unlock) - - (catch 'flock-error - (lambda () - ;; Taking an exclusive lock should raise an exception. - (fcntl-flock file 'write-lock)) - (lambda args - (primitive-exit 0))) + ;; Reopen FILE read-only so we can have a read lock. + (let ((file (open-file temp-file "r"))) + ;; Wait until we can acquire the lock. + (fcntl-flock file 'read-lock) + (primitive-exit (read file))) (primitive-exit 1)) (lambda () (primitive-exit 2)))) (pid + ;; Write garbage and wait. + (display "hello, world!" file) + (force-output file) + (sleep 1) + + ;; Write the real answer. + (seek file 0 SEEK_SET) + (truncate-file file 0) + (write 42 file) + (force-output file) + + ;; Unlock, which should let the child continue. + (fcntl-flock file 'unlock) + (match (waitpid pid) ((_ . status) (let ((result (status:exit-val status))) - (fcntl-flock file 'unlock) (close-port file) result))))))) +(test-equal "fcntl-flock non-blocking" + EAGAIN ; the child's exit status + (match (pipe) + ((input . output) + (match (primitive-fork) + (0 + (dynamic-wind + (const #t) + (lambda () + (close-port output) + + ;; Wait for the green light. + (read-char input) + + ;; Open FILE read-only so we can have a read lock. + (let ((file (open-file temp-file "w"))) + (catch 'flock-error + (lambda () + ;; This attempt should throw EAGAIN. + (fcntl-flock file 'write-lock #:wait? #f)) + (lambda (key errno) + (primitive-exit errno)))) + (primitive-exit -1)) + (lambda () + (primitive-exit -2)))) + (pid + (close-port input) + (let ((file (open-file temp-file "w"))) + ;; Acquire an exclusive lock. + (fcntl-flock file 'write-lock) + + ;; Tell the child to continue. + (write 'green-light output) + (force-output output) + + (match (waitpid pid) + ((_ . status) + (let ((result (status:exit-val status))) + (fcntl-flock file 'unlock) + (close-port file) + result))))))))) + ;; This is actually in (guix store). (test-equal "store-path-package-name" "bash-4.2-p24" @@ -178,5 +233,7 @@ (test-end) +(false-if-exception (delete-file temp-file)) + (exit (= (test-runner-fail-count (test-runner-current)) 0)) |