nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' into core-updates

master
Ludovic Courtès 2014-03-10 23:54:17 +01:00
parent ff3c0c1b80 c9c88118a1
commit e06f7865e2
41 changed files with 1637 additions and 405 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
HACKING
View File

@ -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.)

2
Makefile.am
View File

@ -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) ; \

8
configure.ac
View File

@ -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"],

4
daemon.am
View File

@ -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)\" \

195
doc/guix.texi
View File

@ -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,

8
gnu-system.am
View File

@ -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 \

53
gnu/packages/admin.scm
View File

@ -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+)))

19
gnu/packages/bdw-gc.scm
View File

@ -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"))))

26
gnu/packages/gnupg.scm
View File

@ -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")

10
gnu/packages/gnutls.scm
View File

@ -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

44
gnu/packages/hurd.scm
View File

@ -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+)))

25
gnu/packages/linux.scm
View File

@ -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)))

86
gnu/packages/lynx.scm Normal file
View File

@ -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

123
gnu/packages/messaging.scm Normal file
View File

@ -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

28
gnu/packages/mpd.scm
View File

@ -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)))

33
gnu/packages/patches/bitlbee-fix-tests.patch Normal file
View File

@ -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]);
}
}

15
gnu/packages/patches/bitlbee-memset-fix.patch Normal file
View File

@ -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)

15
gnu/packages/patches/source-highlight-regexrange-test.patch Normal file
View File

@ -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();

224
gnu/packages/pretty-print.scm Normal file
View File

@ -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+)))

52
gnu/packages/python.scm
View File

@ -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")

11
gnu/packages/rdf.scm
View File

@ -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

16
gnu/packages/ssh.scm
View File

@ -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)

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

@ -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)

8
gnu/system/vm.scm
View File

@ -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)

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

@ -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))

2
guix/config.scm.in
View File

@ -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'.

6
guix/download.scm
View File

@ -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)))

3
guix/git-download.scm
View File

@ -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

9
guix/gnu-maintenance.scm
View File

@ -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))

35
guix/http-client.scm
View File

@ -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

3
guix/scripts/archive.scm
View File

@ -63,6 +63,9 @@ Export/import one or more packages from/to the store.\n"))
(display (_ "
--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 (_ "

58
guix/scripts/build.scm
View File

@ -126,6 +126,8 @@ options handled by 'set-build-options-from-command-line', and listed in
(display (_ "
--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 (_ "
@ -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)))))))

365
guix/scripts/offload.scm
View File

@ -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

210
guix/scripts/package.scm
View File

@ -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")))
(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 '("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)))))
(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)

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

@ -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~%"))
(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)))))))
;; 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?)

12
guix/serialization.scm
View File

@ -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)

25
guix/store.scm
View File

@ -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")))

35
guix/utils.scm
View File

@ -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)))))))
;;;

14
tests/derivations.scm
View File

@ -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

22
tests/store.scm
View File

@ -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"

87
tests/utils.scm
View File

@ -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))