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

Merge branch 'master' into core-updates

This commit is contained in:
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 #+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 © 2013 Nikita Karetnikov <nikita@karetnikov.org>
Copyright © 2014 Pierre-Antoine Rault <par@rigelk.eu>
Copying and distribution of this file, with or without modification, Copying and distribution of this file, with or without modification,
are permitted in any medium without royalty provided the copyright 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, Development is done using the Git distributed version control system. Thus,
access to the repository is not strictly necessary. We welcome contributions access to the repository is not strictly necessary. We welcome contributions
in the form of patches as produced by ‘git format-patch’ sent to 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 As you become a regular contributor, you may find it convenient to have write
access to the repository (see below.) access to the repository (see below.)

2
Makefile.am
View File

@ -263,7 +263,7 @@ gen-ChangeLog:
mv $(distdir)/cl-t $(distdir)/ChangeLog; \ mv $(distdir)/cl-t $(distdir)/ChangeLog; \
fi 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: assert-no-store-file-names:
if grep -r --exclude=*.texi --exclude=*.info \ if grep -r --exclude=*.texi --exclude=*.info \
"$(storedir)/[a-z0-9]{32}-" $(distdir) ; \ "$(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_ARG_WITH(store-dir,
AC_HELP_STRING([--with-store-dir=PATH], 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="$withval"],
[storedir="/nix/store"]) [storedir="/gnu/store"])
AC_SUBST(storedir) AC_SUBST(storedir)
dnl Better be verbose.
AC_MSG_CHECKING([for the store directory])
AC_MSG_RESULT([$storedir])
AC_ARG_ENABLE([daemon], AC_ARG_ENABLE([daemon],
[AS_HELP_STRING([--disable-daemon], [build the Nix daemon (C++)])], [AS_HELP_STRING([--disable-daemon], [build the Nix daemon (C++)])],
[guix_build_daemon="$enableval"], [guix_build_daemon="$enableval"],

4
daemon.am
View File

@ -112,8 +112,8 @@ libstore_a_CPPFLAGS = \
-I$(top_builddir)/nix/libstore \ -I$(top_builddir)/nix/libstore \
-DNIX_STORE_DIR=\"$(storedir)\" \ -DNIX_STORE_DIR=\"$(storedir)\" \
-DNIX_DATA_DIR=\"$(datadir)\" \ -DNIX_DATA_DIR=\"$(datadir)\" \
-DNIX_STATE_DIR=\"$(localstatedir)/nix\" \ -DNIX_STATE_DIR=\"$(localstatedir)/guix\" \
-DNIX_LOG_DIR=\"$(localstatedir)/log/nix\" \ -DNIX_LOG_DIR=\"$(localstatedir)/log/guix\" \
-DNIX_CONF_DIR=\"$(sysconfdir)/guix\" \ -DNIX_CONF_DIR=\"$(sysconfdir)/guix\" \
-DNIX_LIBEXEC_DIR=\"$(libexecdir)\" \ -DNIX_LIBEXEC_DIR=\"$(libexecdir)\" \
-DNIX_BIN_DIR=\"$(bindir)\" \ -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 The result of package build functions is @dfn{cached} in the file
system, in a special directory called @dfn{the store} (@pxref{The 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}). 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 a hash of all the inputs used to build that package; thus, changing an
input yields a different directory name. 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 same @code{--with-store-dir} value, but also the same
@code{--localstatedir} value. The latter is essential because it @code{--localstatedir} value. The latter is essential because it
specifies where the database that stores metadata about the store is 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}. @code{--with-store-dir=/nix/store} and @code{--localstatedir=/nix/var}.
Note that @code{--disable-daemon} is not required if Note that @code{--disable-daemon} is not required if
your goal is to share the store with Nix. 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 In a standard multi-user setup, Guix and its daemon---the
@command{guix-daemon} program---are installed by the system @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 @command{guix-daemon} runs as @code{root}. Unprivileged users may use
Guix tools to build packages or otherwise access the store, and the 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 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 When using Guix, each package ends up in the @dfn{package store}, in its
own directory---something that resembles 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 Instead of referring to these directories, users have their own
@dfn{profile}, which points to the packages that they actually want to @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, For example, @code{alice} installs GCC 4.7.2. As a result,
@file{/home/alice/.guix-profile/bin/gcc} points to @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} @code{bob} had already installed GCC 4.8.0. The profile of @code{bob}
simply continues to point to 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. coexist on the same system without any interference.
The @command{guix package} command is the central tool to manage The @command{guix package} command is the central tool to manage
@ -621,7 +621,7 @@ collected.
@cindex reproducible builds @cindex reproducible builds
Finally, Guix takes a @dfn{purely functional} approach to package Finally, Guix takes a @dfn{purely functional} approach to package
management, as described in the introduction (@pxref{Introduction}). 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 inputs that were used to build that package---compiler, libraries, build
scripts, etc. This direct correspondence allows users to make sure a scripts, etc. This direct correspondence allows users to make sure a
given package installation matches the current state of their given package installation matches the current state of their
@ -632,7 +632,7 @@ machines (@pxref{Invoking guix-daemon, container}).
@cindex substitute @cindex substitute
This foundation allows Guix to support @dfn{transparent binary/source 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 available from an external source---a @dfn{substitute}, Guix just
downloads it@footnote{@c XXX: Remove me when outdated. downloads it@footnote{@c XXX: Remove me when outdated.
As of version @value{VERSION}, substitutes are downloaded from 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} 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 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} 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 @cindex propagated inputs
Sometimes packages have @dfn{propagated inputs}: these are dependencies 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} @itemx -p @var{profile}
Use @var{profile} instead of the user's default 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 @item --verbose
Produce verbose output. In particular, emit the environment's build log Produce verbose output. In particular, emit the environment's build log
on the standard error port. on the standard error port.
@ -918,6 +905,10 @@ Consequently, this command must be used with care.
@end table @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 @node Packages with Multiple Outputs
@section Packages with Multiple Outputs @section Packages with Multiple Outputs
@ -974,10 +965,10 @@ guix package}).
@cindex garbage collector @cindex garbage collector
Packages that are installed but not used may be @dfn{garbage-collected}. Packages that are installed but not used may be @dfn{garbage-collected}.
The @command{guix gc} command allows users to explicitly run the garbage 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 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 cannot be deleted; any other file is considered @dfn{dead} and may be
deleted. The set of garbage collector roots includes default user deleted. The set of garbage collector roots includes default user
profiles, and may be augmented with @command{guix build --root}, for profiles, and may be augmented with @command{guix build --root}, for
@ -997,7 +988,7 @@ information. The available options are listed below:
@table @code @table @code
@item --collect-garbage[=@var{min}] @item --collect-garbage[=@var{min}]
@itemx -C [@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 sub-directories. This is the default operation when no option is
specified. specified.
@ -1170,13 +1161,13 @@ containing the @code{gui} output of the @code{git} package and the main
output of @code{emacs}: output of @code{emacs}:
@example @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 @end example
If the specified packages are not built yet, @command{guix archive} If the specified packages are not built yet, @command{guix archive}
automatically builds them. The build process may be controlled with the automatically builds them. The build process may be controlled with the
same options that can be passed to the @command{guix build} command same options that can be passed to the @command{guix build} command
(@pxref{Invoking guix build}). (@pxref{Invoking guix build, common build options}).
@c ********************************************************************* @c *********************************************************************
@ -1192,7 +1183,7 @@ turned into concrete build actions.
Build actions are performed by the Guix daemon, on behalf of users. In a 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 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 setup also has the daemon perform builds in chroots, under a specific
build users, to minimize interference with the rest of the system. 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: package looks like this:
@example @example
(use-modules (guix packages) (define-module (gnu packages hello)
(guix download) #:use-module (guix packages)
(guix build-system gnu) #:use-module (guix download)
(guix licenses)) #:use-module (guix build-system gnu)
#:use-module (guix licenses))
(define hello (define hello
(package (package
@ -1248,13 +1240,19 @@ package looks like this:
@noindent @noindent
Without being a Scheme expert, the reader may have guessed the meaning 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 to a @code{<package>} object, which is essentially a record
(@pxref{SRFI-9, Scheme records,, guile, GNU Guile Reference Manual}). (@pxref{SRFI-9, Scheme records,, guile, GNU Guile Reference Manual}).
This package object can be inspected using procedures found in the This package object can be inspected using procedures found in the
@code{(guix packages)} module; for instance, @code{(package-name hello)} @code{(guix packages)} module; for instance, @code{(package-name hello)}
returns---surprise!---@code{"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: There are a few points worth noting in the above package definition:
@itemize @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>} Behind the scenes, a derivation corresponding to the @code{<package>}
object is first computed by the @code{package-derivation} procedure. 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 The build actions it prescribes may then be realized by using the
@code{build-derivations} procedure (@pxref{The Store}). @code{build-derivations} procedure (@pxref{The Store}).
@ -1381,7 +1379,7 @@ Configure and Build System}).
@cindex store paths @cindex store paths
Conceptually, the @dfn{store} is where derivations that have been 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 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 has an associated database that contains information such has the
store paths referred to by each store path, and the list of @emph{valid} 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" (derivation store "foo"
bash `("-e" ,builder) bash `("-e" ,builder)
#:env-vars '(("HOME" . "/homeless")))) #: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 @end lisp
As can be guessed, this primitive is cumbersome to use directly. An As can be guessed, this primitive is cumbersome to use directly. An
@ -1570,13 +1568,13 @@ containing one file:
@lisp @lisp
(let ((builder '(let ((out (assoc-ref %outputs "out"))) (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") (call-with-output-file (string-append out "/test")
(lambda (p) (lambda (p)
(display '(hello guix) p)))))) (display '(hello guix) p))))))
(build-expression->derivation store "goo" builder)) (build-expression->derivation store "goo" builder))
@result{} #<derivation /nix/store/@dots{}-goo.drv => @dots{}> @result{} #<derivation /gnu/store/@dots{}-goo.drv => @dots{}>
@end lisp @end lisp
@cindex strata of code @cindex strata of code
@ -1654,7 +1652,7 @@ effect, one must use @code{run-with-store}:
@example @example
(run-with-store (open-connection) (profile.sh)) (run-with-store (open-connection) (profile.sh))
@result{} /nix/store/...-profile.sh @result{} /gnu/store/...-profile.sh
@end example @end example
The main syntactic forms to deal with monads in general are described The main syntactic forms to deal with monads in general are described
@ -1729,7 +1727,7 @@ like this:
grep "/bin:" sed "/bin\n")) grep "/bin:" sed "/bin\n"))
@end example @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 will references @var{coreutils}, @var{grep}, and @var{sed}, thereby
preventing them from being garbage-collected during its lifetime. preventing them from being garbage-collected during its lifetime.
@end deffn @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 @var{package-or-derivation} may be either the name of a package found in
the software distribution such as @code{coreutils} or the software distribution such as @code{coreutils} or
@code{coreutils-8.20}, or a derivation such as @code{coreutils-8.20}, or a derivation such as
@file{/nix/store/@dots{}-coreutils-8.19.drv}. Alternatively, the @file{/gnu/store/@dots{}-coreutils-8.19.drv}. In the former case, a
@code{--expression} option may be used to specify a Scheme expression package with the corresponding name (and optionally version) is searched
that evaluates to a package; this is useful when disambiguation among for among the GNU distribution modules (@pxref{Package Modules}).
several same-named packages or package variants is needed.
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: 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. themselves.
For instance, @code{guix build -S gcc} returns something like 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 The returned source tarball is the result of applying any patches and
code snippets specified in the package's @code{origin} (@pxref{Defining 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 Return the derivation paths, not the output paths, of the given
packages. 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 @item --keep-failed
@itemx -K @itemx -K
Keep the build tree of failed builds. Thus, if a build fail, its build 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 When the build or substitution process remains silent for more than
@var{seconds}, terminate it and report a build failure. @var{seconds}, terminate it and report a build failure.
@item --cores=@var{n} @item --timeout=@var{seconds}
@itemx -c @var{n} Likewise, when the build or substitution process lasts for more than
Allow the use of up to @var{n} CPU cores for the build. The special @var{seconds}, terminate it and report a build failure.
value @code{0} means to use as many CPU cores as available.
@item --root=@var{file} By default there is no timeout. This behavior can be restored with
@itemx -r @var{file} @code{--timeout=0}.
Make @var{file} a symlink to the result, and register it as a garbage
collector root.
@item --verbosity=@var{level} @item --verbosity=@var{level}
Use the given verbosity level. @var{level} must be an integer between 0 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 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. may be helpful when debugging setup issues with the build daemon.
@item --log-file @item --cores=@var{n}
Return the build log file names for the given @itemx -c @var{n}
@var{package-or-derivation}s, or raise an error if build logs are Allow the use of up to @var{n} CPU cores for the build. The special
missing. value @code{0} means to use as many CPU cores as available.
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 @end table
@ -2184,7 +2203,7 @@ the load. To check whether a package has a @code{debug} output, use
@section Package Modules @section Package Modules
From a programming viewpoint, the package definitions of the 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 @dots{})} name space@footnote{Note that packages under the @code{(gnu
packages @dots{})} module name space are not necessarily ``GNU packages @dots{})} module name space are not necessarily ``GNU
packages''. This module naming scheme follows the usual Guile module 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 define packages.} (@pxref{Modules, Guile modules,, guile, GNU Guile
Reference Manual}). For instance, the @code{(gnu packages emacs)} Reference Manual}). For instance, the @code{(gnu packages emacs)}
module exports a variable named @code{emacs}, which is bound to a module exports a variable named @code{emacs}, which is bound to a
@code{<package>} object (@pxref{Defining Packages}). The @code{(gnu @code{<package>} object (@pxref{Defining Packages}).
packages)} module provides facilities for searching for 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}: The distribution is fully @dfn{bootstrapped} and @dfn{self-contained}:
each package is built based solely on other packages in the 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 Using @code{--keep-failed} makes it easier to debug build failures since
it provides access to the failed build tree. 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 Once your package builds correctly, please send us a patch
(@pxref{Contributing}). Well, if you need help, we will be happy to (@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 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 Bootstrapping is complete when we have a full tool chain that does not
depend on the pre-built bootstrap tools discussed above. This depend on the pre-built bootstrap tools discussed above. This
no-dependency requirement is verified by checking whether the files of 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 directories of the bootstrap inputs. The process that leads to this
``final'' tool chain is described by the package definitions found in ``final'' tool chain is described by the package definitions found in
the @code{(gnu packages base)} module. the @code{(gnu packages base)} module.
@ -2754,10 +2793,10 @@ deco,,, dmd, GNU dmd Manual}).
@chapter Contributing @chapter Contributing
This project is a cooperative effort, and we need your help to make it 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 grow! Please get in touch with us on @email{guix-devel@@gnu.org} and
welcome ideas, bug reports, patches, and anything that may be helpful to @code{#guix} on the Freenode IRC network. We welcome ideas, bug
the project. We particularly welcome help on packaging reports, patches, and anything that may be helpful to the project. We
(@pxref{Packaging Guidelines}). particularly welcome help on packaging (@pxref{Packaging Guidelines}).
Please see the Please see the
@url{http://git.savannah.gnu.org/cgit/guix.git/tree/HACKING, @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 # GNU Guix --- Functional package management for GNU
# Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> # Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
# Copyright © 2013 Andreas Enge <andreas@enge.fr> # 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. # This file is part of GNU Guix.
# #
@ -139,10 +139,12 @@ GNU_SYSTEM_MODULES = \
gnu/packages/lsof.scm \ gnu/packages/lsof.scm \
gnu/packages/lua.scm \ gnu/packages/lua.scm \
gnu/packages/lvm.scm \ gnu/packages/lvm.scm \
gnu/packages/lynx.scm \
gnu/packages/m4.scm \ gnu/packages/m4.scm \
gnu/packages/mail.scm \ gnu/packages/mail.scm \
gnu/packages/make-bootstrap.scm \ gnu/packages/make-bootstrap.scm \
gnu/packages/maths.scm \ gnu/packages/maths.scm \
gnu/packages/messaging.scm \
gnu/packages/mit-krb5.scm \ gnu/packages/mit-krb5.scm \
gnu/packages/moe.scm \ gnu/packages/moe.scm \
gnu/packages/mpd.scm \ gnu/packages/mpd.scm \
@ -174,6 +176,7 @@ GNU_SYSTEM_MODULES = \
gnu/packages/popt.scm \ gnu/packages/popt.scm \
gnu/packages/pth.scm \ gnu/packages/pth.scm \
gnu/packages/pulseaudio.scm \ gnu/packages/pulseaudio.scm \
gnu/packages/pretty-print.scm \
gnu/packages/python.scm \ gnu/packages/python.scm \
gnu/packages/qemu.scm \ gnu/packages/qemu.scm \
gnu/packages/qt.scm \ gnu/packages/qt.scm \
@ -249,6 +252,8 @@ dist_patch_DATA = \
gnu/packages/patches/bigloo-gc-shebangs.patch \ gnu/packages/patches/bigloo-gc-shebangs.patch \
gnu/packages/patches/binutils-ld-new-dtags.patch \ gnu/packages/patches/binutils-ld-new-dtags.patch \
gnu/packages/patches/binutils-loongson-workaround.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/cdparanoia-fpic.patch \
gnu/packages/patches/cmake-fix-tests.patch \ gnu/packages/patches/cmake-fix-tests.patch \
gnu/packages/patches/coreutils-dummy-man.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-session.patch \
gnu/packages/patches/slim-config.patch \ gnu/packages/patches/slim-config.patch \
gnu/packages/patches/slim-sigusr1.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/tcsh-fix-autotest.patch \
gnu/packages/patches/teckit-cstdio.patch \ gnu/packages/patches/teckit-cstdio.patch \
gnu/packages/patches/valgrind-glibc.patch \ gnu/packages/patches/valgrind-glibc.patch \

53
gnu/packages/admin.scm
View File

@ -36,6 +36,9 @@
#:select (tar)) #:select (tar))
#:use-module ((gnu packages compression) #:use-module ((gnu packages compression)
#:select (gzip)) #:select (gzip))
#:use-module (gnu packages bison)
#:use-module (gnu packages flex)
#:use-module (gnu packages glib)
#:use-module (gnu packages pkg-config)) #:use-module (gnu packages pkg-config))
(define-public dmd (define-public dmd
@ -429,3 +432,53 @@ connection alive.")
reference implementation of all aspects of DHCP, through a suite of DHCP reference implementation of all aspects of DHCP, through a suite of DHCP
tools: server, client, and relay agent.") tools: server, client, and relay agent.")
(license isc))) (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") (version "7.2d")
(source (origin (source (origin
(method url-fetch) (method url-fetch)
(uri (string-append (uri (string-append "http://www.hboehm.info/gc/gc_source/gc-"
"http://www.hpl.hp.com/personal/Hans_Boehm/gc/gc_source/gc-" version ".tar.gz"))
version ".tar.gz"))
(sha256 (sha256
(base32 (base32
"0phwa5driahnpn79zqff14w9yc8sn3599cxz91m78hqdcpl0mznr")))) "0phwa5driahnpn79zqff14w9yc8sn3599cxz91m78hqdcpl0mznr"))))
@ -58,10 +57,9 @@ simple collector interface.
Alternatively, the garbage collector may be used as a leak detector for Alternatively, the garbage collector may be used as a leak detector for
C or C++ programs, though that is not its primary goal.") 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 (license (x11-style (string-append home-page "license.txt")))))
(x11-style "http://www.hpl.hp.com/personal/Hans_Boehm/gc/license.txt"))))
(define-public libatomic-ops (define-public libatomic-ops
(package (package
@ -70,7 +68,7 @@ C or C++ programs, though that is not its primary goal.")
(source (origin (source (origin
(method url-fetch) (method url-fetch)
(uri (string-append (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")) version ".tar.gz"))
(sha256 (sha256
(base32 (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 memory update operations on a number architectures. These might allow you to
write code that does more interesting things in signal handlers, write write code that does more interesting things in signal handlers, write
lock-free code, experiment with thread programming paradigms, etc.") 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+. ;; Some source files are X11-style, others are GPLv2+.
(license gpl2+))) (license gpl2+)))
@ -93,9 +91,8 @@ lock-free code, experiment with thread programming paradigms, etc.")
(version "7.4.0") (version "7.4.0")
(source (origin (source (origin
(method url-fetch) (method url-fetch)
(uri (string-append (uri (string-append "http://www.hboehm.info/gc/gc_source/gc-"
"http://www.hpl.hp.com/personal/Hans_Boehm/gc/gc_source/gc-" version ".tar.gz"))
version ".tar.gz"))
(sha256 (sha256
(base32 (base32
"10z2nph62ilab063wygg2lv0jxlsbcf2az9w1lx01jzqj5lzry31")))) "10z2nph62ilab063wygg2lv0jxlsbcf2az9w1lx01jzqj5lzry31"))))

26
gnu/packages/gnupg.scm
View File

@ -2,6 +2,7 @@
;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2014 Mark H Weaver <mhw@netris.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; 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).") (working with X.509 certificates and CMS data).")
(license gpl3+))) (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 (define-public gpgme
(package (package
(name "gpgme") (name "gpgme")

10
gnu/packages/gnutls.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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> ;;; Copyright © 2014 Mark H Weaver <mhw@netris.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
@ -63,7 +63,7 @@ specifications.")
(define-public gnutls (define-public gnutls
(package (package
(name "gnutls") (name "gnutls")
(version "3.2.11") (version "3.2.12")
(source (origin (source (origin
(method url-fetch) (method url-fetch)
(uri (uri
@ -75,8 +75,12 @@ specifications.")
"/gnutls-" version ".tar.xz")) "/gnutls-" version ".tar.xz"))
(sha256 (sha256
(base32 (base32
"1hgk3k8f6wqijca3bsjbfn8pzyfva509y4j2vaxhm4ynfa5cai5q")))) "0195nliarszq5mginli6d2f5z7ljnd7mwa46iy9z8pkcgy56khbl"))))
(build-system gnu-build-system) (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 (native-inputs
`(("pkg-config" ,pkg-config))) `(("pkg-config" ,pkg-config)))
(inputs (inputs

44
gnu/packages/hurd.scm
View File

@ -22,7 +22,9 @@
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix build-system gnu) #:use-module (guix build-system gnu)
#:use-module (gnu packages flex) #: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 (define-public gnumach-headers
(package (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 for other software in the GNU system that uses Mach-based inter-process
communication.") communication.")
(license gpl2+))) (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 packages)
#:use-module (guix download) #:use-module (guix download)
#:use-module (guix build-system gnu) #:use-module (guix build-system gnu)
#:use-module (guix build-system cmake)
#:use-module (guix build-system python)) #:use-module (guix build-system python))
(define-public (system->linux-architecture arch) (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.") user-space processes.")
(license (list lgpl2.1 ; library (license (list lgpl2.1 ; library
gpl2+)))) ; command-line utilities 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 glib)
#:use-module (gnu packages linux) #:use-module (gnu packages linux)
#:use-module (gnu packages mp3) #:use-module (gnu packages mp3)
#:use-module (gnu packages ncurses)
#:use-module (gnu packages pkg-config) #:use-module (gnu packages pkg-config)
#:use-module (gnu packages pulseaudio) #:use-module (gnu packages pulseaudio)
#:use-module (gnu packages sqlite) #:use-module (gnu packages sqlite)
#:use-module (gnu packages video) #:use-module (gnu packages video)
#:use-module (gnu packages xiph) #:use-module (gnu packages xiph)
#:export (libmpdclient #:export (libmpdclient
mpd)) mpd
ncmpc))
(define libmpdclient (define libmpdclient
(package (package
@ -121,3 +123,27 @@ can play a variety of sound files while being controlled by its network
protocol.") protocol.")
(home-page "http://www.musicpd.org/") (home-page "http://www.musicpd.org/")
(license license:gpl2))) (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) (define-module (gnu packages python)
#:use-module ((guix licenses) #: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) #:use-module ((guix licenses) #:select (zlib)
#:renamer (symbol-prefix-proc 'license:)) #:renamer (symbol-prefix-proc 'license:))
#:use-module (gnu packages) #:use-module (gnu packages)
@ -505,6 +506,55 @@ system is highly configurable via command line options and embedded
commands.") commands.")
(license lgpl2.1+))) (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 (define-public scons
(package (package
(name "scons") (name "scons")

11
gnu/packages/rdf.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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. ;;; This file is part of GNU Guix.
;;; ;;;
@ -45,6 +45,8 @@
("libxml2" ,libxml2) ("libxml2" ,libxml2)
("libxslt" ,libxslt) ("libxslt" ,libxslt)
("zlib" ,zlib))) ("zlib" ,zlib)))
(arguments
`(#:parallel-tests? #f))
(home-page "http://librdf.org/raptor/") (home-page "http://librdf.org/raptor/")
(synopsis "RDF syntax library") (synopsis "RDF syntax library")
(description "Raptor is a C library providing a set of parsers and (description "Raptor is a C library providing a set of parsers and
@ -76,11 +78,12 @@ HTML and JSON.")
(base32 (base32
"08gb5d8bgy7vc6qd6r1kkmmc5rli67dlglpjqjlahpnvs26r1cwl")))) "08gb5d8bgy7vc6qd6r1kkmmc5rli67dlglpjqjlahpnvs26r1cwl"))))
(build-system cmake-build-system) (build-system cmake-build-system)
;; FIXME: Add optional dependencies: Raptor, Redland, odbci, clucene; doxygen ;; FIXME: Add optional dependencies: Redland, odbci, clucene; doxygen
(inputs
`(("qt" ,qt-4)))
(native-inputs (native-inputs
`(("pkg-config" ,pkg-config))) `(("pkg-config" ,pkg-config)))
(inputs
`(("qt" ,qt-4)
("raptor2" ,raptor2)))
(home-page "http://soprano.sourceforge.net/") (home-page "http://soprano.sourceforge.net/")
(synopsis "RDF data library for Qt") (synopsis "RDF data library for Qt")
(description "Soprano (formerly known as QRDF) is a library which (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 guile)
#:use-module (gnu packages pkg-config) #:use-module (gnu packages pkg-config)
#:use-module (gnu packages autotools) #:use-module (gnu packages autotools)
#:use-module (gnu packages texinfo)
#:use-module (gnu packages which) #:use-module (gnu packages which)
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix download) #:use-module (guix download)
@ -185,7 +186,7 @@ Additionally, various channel-specific options can be negotiated.")
(define-public guile-ssh (define-public guile-ssh
(package (package
(name "guile-ssh") (name "guile-ssh")
(version "0.4.0") (version "0.5.0")
(source (origin (source (origin
(method url-fetch) (method url-fetch)
(uri (string-append (uri (string-append
@ -193,13 +194,13 @@ Additionally, various channel-specific options can be negotiated.")
version ".tar.gz")) version ".tar.gz"))
(sha256 (sha256
(base32 (base32
"0vw02r261amkp6238cflww2y9y1v6vfx9ias6hvn8dlx0ghrd5dw")))) "13wk2fj08b8zjylvf78l3d9pf8y3zqcd7h75jf15a46iprk00n7q"))))
(build-system gnu-build-system) (build-system gnu-build-system)
(arguments (arguments
'(#:phases (alist-cons-before '(#:phases (alist-cons-before
'configure 'autoreconf 'configure 'autoreconf
(lambda* (#:key inputs #:allow-other-keys) (lambda* (#:key inputs #:allow-other-keys)
(substitute* "src/Makefile.am" (substitute* "ssh/Makefile.am"
(("-lssh_threads" match) (("-lssh_threads" match)
(string-append "-L" (assoc-ref inputs "libssh") (string-append "-L" (assoc-ref inputs "libssh")
"/lib " match))) "/lib " match)))
@ -223,10 +224,17 @@ Additionally, various channel-specific options can be negotiated.")
%standard-phases)) %standard-phases))
#:configure-flags (list (string-append "--with-guilesitedir=" #:configure-flags (list (string-append "--with-guilesitedir="
(assoc-ref %outputs "out") (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) (native-inputs `(("autoconf" ,autoconf)
("automake" ,automake) ("automake" ,automake)
("libtool" ,libtool "bin") ("libtool" ,libtool "bin")
("texinfo" ,texinfo)
("pkg-config" ,pkg-config) ("pkg-config" ,pkg-config)
("which" ,which))) ("which" ,which)))
(inputs `(("guile" ,guile-2.0) (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 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2013 Cyril Roelandt <tipecaml@gmail.com> ;;; Copyright © 2013 Cyril Roelandt <tipecaml@gmail.com>
;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; 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. ;;; This file is part of GNU Guix.
;;; ;;;
@ -26,13 +26,15 @@
#:use-module (guix build-system gnu) #:use-module (guix build-system gnu)
#:use-module (guix build-system python) #:use-module (guix build-system python)
#:use-module (guix build utils) #:use-module (guix build utils)
#:use-module (gnu packages gettext)
#:use-module (gnu packages apr) #:use-module (gnu packages apr)
#:use-module (gnu packages curl) #:use-module (gnu packages curl)
#:use-module (gnu packages ed) #:use-module (gnu packages ed)
#:use-module (gnu packages gettext)
;; #:use-module (gnu packages gnutls)
#:use-module (gnu packages nano) #:use-module (gnu packages nano)
#:use-module (gnu packages openssl) #:use-module (gnu packages openssl)
#:use-module (gnu packages perl) #:use-module (gnu packages perl)
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages python) #:use-module (gnu packages python)
#:use-module (gnu packages sqlite) #:use-module (gnu packages sqlite)
#:use-module (gnu packages admin) #:use-module (gnu packages admin)
@ -216,17 +218,77 @@ It efficiently handles projects of any size
and offers an easy and intuitive interface.") and offers an easy and intuitive interface.")
(license gpl2+))) (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 (define-public subversion
(package (package
(name "subversion") (name "subversion")
(version "1.7.8") (version "1.7.14")
(source (origin (source (origin
(method url-fetch) (method url-fetch)
(uri (string-append "http://archive.apache.org/dist/subversion/subversion-" (uri (string-append "http://archive.apache.org/dist/subversion/subversion-"
version ".tar.bz2")) version ".tar.bz2"))
(sha256 (sha256
(base32 (base32
"11inl9n1riahfnbk1fax0dysm2swakzhzhpmm2zvga6fikcx90zw")))) "038jbcpwm083abp0rvk0fhnx65kp9mz1qvzs3f83ig8fxcvqzb64"))))
(build-system gnu-build-system) (build-system gnu-build-system)
(arguments (arguments
'(#:phases (alist-cons-after '(#:phases (alist-cons-after
@ -250,11 +312,13 @@ and offers an easy and intuitive interface.")
(system* "make" "install"))))))) (system* "make" "install")))))))
%standard-phases))) %standard-phases)))
(native-inputs (native-inputs
;; For the Perl bindings. `(("pkg-config" ,pkg-config)
`(("swig" ,swig))) ;; For the Perl bindings.
("swig" ,swig)))
(inputs (inputs
`(("apr" ,apr) `(("apr" ,apr)
("apr-util" ,apr-util) ("apr-util" ,apr-util)
("neon" ,neon-0.29.6)
("perl" ,perl) ("perl" ,perl)
("python" ,python-2) ; incompatible with Python 3 (print syntax) ("python" ,python-2) ; incompatible with Python 3 (print syntax)
("sqlite" ,sqlite) ("sqlite" ,sqlite)

8
gnu/system/vm.scm
View File

@ -383,7 +383,13 @@ such as /etc files."
(system* grub "--no-floppy" (system* grub "--no-floppy"
"--boot-directory" "/fs/boot" "--boot-directory" "/fs/boot"
"/dev/sda")) "/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)))))))) (reboot))))))))
#:system system #:system system
#:inputs `(("parted" ,parted) #:inputs `(("parted" ,parted)

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

@ -114,6 +114,14 @@
(device-number 4 n)) (device-number 4 n))
(loop (+ 1 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. ;; Rendez-vous point for syslogd.
(mknod (scope "dev/log") 'socket #o666 0) (mknod (scope "dev/log") 'socket #o666 0)
(mknod (scope "dev/kmsg") 'char-special #o600 (device-number 1 11)) (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 (define %state-directory
;; This must match `NIX_STATE_DIR' as defined in `daemon.am'. ;; 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 (define %config-directory
;; This must match `NIX_CONF_DIR' as defined in `daemon.am'. ;; 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 build utils)
(guix ftp-client)) (guix ftp-client))
#:guile-for-build guile-for-build #: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)) (define* (download-to-store store url #:optional (name (basename url))
#:key (log (current-error-port))) #: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 #:recursive? #t
#:modules '((guix build git) #:modules '((guix build git)
(guix build utils)) (guix build utils))
#:guile-for-build guile-for-build))) #:guile-for-build guile-for-build
#:local-build? #t)))
;;; git-download.scm ends here ;;; git-download.scm ends here

9
guix/gnu-maintenance.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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> ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; 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? (define contains-digit?
(cut string-any char-set: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))) (let-values (((server directory) (ftp-server/directory project)))
(define conn (ftp-open server)) (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., ;; Filter out sub-directories that do not contain digits---e.g.,
;; /gnuzilla/lang and /gnupg/patches. ;; /gnuzilla/lang and /gnupg/patches.
(subdirs (filter-map (match-lambda (subdirs (filter-map (match-lambda
(((? patch-directory-name? dir)
'directory . _)
#f)
(((? contains-digit? dir) 'directory . _) (((? contains-digit? dir) 'directory . _)
dir) dir)
(_ #f)) (_ #f))

35
guix/http-client.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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. ;;; Copyright © 2012 Free Software Foundation, Inc.
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
@ -23,19 +23,36 @@
#:use-module (web client) #:use-module (web client)
#:use-module (web response) #:use-module (web response)
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (rnrs io ports) #:use-module (rnrs io ports)
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)
#:use-module (guix ui) #:use-module (guix ui)
#:use-module (guix utils) #: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)) http-fetch))
;;; Commentary: ;;; Commentary:
;;; ;;;
;;; HTTP client portable among Guile versions. ;;; HTTP client portable among Guile versions, and with proper error condition
;;; reporting.
;;; ;;;
;;; Code: ;;; 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 (define-syntax when-guile<=2.0.5
(lambda (s) (lambda (s)
(syntax-case s () (syntax-case s ()
@ -154,7 +171,9 @@ unbuffered."
"Return an input port containing the data at URI, and the expected number of "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 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 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 loop ((uri uri))
(let ((port (or port (let ((port (or port
(open-socket-for-uri uri (open-socket-for-uri uri
@ -202,7 +221,11 @@ unbuffered port, suitable for use in `filtered-port'."
(uri->string uri)) (uri->string uri))
(loop uri))) (loop uri)))
(else (else
(error "download failed" uri code (raise (condition (&http-get-error
(response-reason-phrase resp)))))))) (uri uri)
(code code)
(reason (response-reason-phrase resp)))
(&message
(message "download failed"))))))))))
;;; http-client.scm ends here ;;; 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 (_ " (display (_ "
--generate-key[=PARAMETERS] --generate-key[=PARAMETERS]
generate a key pair with the given parameters")) generate a key pair with the given parameters"))
(display (_ "
--authorize authorize imports signed by the public key on stdin"))
(newline)
(display (_ " (display (_ "
-e, --expression=EXPR build the package or derivation EXPR evaluates to")) -e, --expression=EXPR build the package or derivation EXPR evaluates to"))
(display (_ " (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 (_ " (display (_ "
--max-silent-time=SECONDS --max-silent-time=SECONDS
mark the build as failed after SECONDS of silence")) mark the build as failed after SECONDS of silence"))
(display (_ "
--timeout=SECONDS mark the build as failed after SECONDS of activity"))
(display (_ " (display (_ "
--verbosity=LEVEL use the given verbosity LEVEL")) --verbosity=LEVEL use the given verbosity LEVEL"))
(display (_ " (display (_ "
@ -142,39 +144,57 @@ options handled by 'set-build-options-from-command-line', and listed in
#:use-substitutes? (assoc-ref opts 'substitutes?) #:use-substitutes? (assoc-ref opts 'substitutes?)
#:use-build-hook? (assoc-ref opts 'build-hook?) #:use-build-hook? (assoc-ref opts 'build-hook?)
#:max-silent-time (assoc-ref opts 'max-silent-time) #:max-silent-time (assoc-ref opts 'max-silent-time)
#:timeout (assoc-ref opts 'timeout)
#:verbosity (assoc-ref opts 'verbosity))) #:verbosity (assoc-ref opts 'verbosity)))
(define %standard-build-options (define %standard-build-options
;; List of standard command-line options for tools that build something. ;; List of standard command-line options for tools that build something.
(list (option '(#\K "keep-failed") #f #f (list (option '(#\K "keep-failed") #f #f
(lambda (opt name arg result) (lambda (opt name arg result . rest)
(alist-cons 'keep-failed? #t result))) (apply values
(alist-cons 'keep-failed? #t result)
rest)))
(option '("fallback") #f #f (option '("fallback") #f #f
(lambda (opt name arg result) (lambda (opt name arg result . rest)
(alist-cons 'fallback? #t (apply values
(alist-delete 'fallback? result)))) (alist-cons 'fallback? #t
(alist-delete 'fallback? result))
rest)))
(option '("no-substitutes") #f #f (option '("no-substitutes") #f #f
(lambda (opt name arg result) (lambda (opt name arg result . rest)
(alist-cons 'substitutes? #f (apply values
(alist-delete 'substitutes? result)))) (alist-cons 'substitutes? #f
(alist-delete 'substitutes? result))
rest)))
(option '("no-build-hook") #f #f (option '("no-build-hook") #f #f
(lambda (opt name arg result) (lambda (opt name arg result . rest)
(alist-cons 'build-hook? #f (apply values
(alist-delete 'build-hook? result)))) (alist-cons 'build-hook? #f
(alist-delete 'build-hook? result))
rest)))
(option '("max-silent-time") #t #f (option '("max-silent-time") #t #f
(lambda (opt name arg result) (lambda (opt name arg result . rest)
(alist-cons 'max-silent-time (string->number* arg) (apply values
result))) (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 (option '("verbosity") #t #f
(lambda (opt name arg result) (lambda (opt name arg result . rest)
(let ((level (string->number arg))) (let ((level (string->number arg)))
(alist-cons 'verbosity level (apply values
(alist-delete 'verbosity result))))) (alist-cons 'verbosity level
(alist-delete 'verbosity result))
rest))))
(option '(#\c "cores") #t #f (option '(#\c "cores") #t #f
(lambda (opt name arg result) (lambda (opt name arg result . rest)
(let ((c (false-if-exception (string->number arg)))) (let ((c (false-if-exception (string->number arg))))
(if c (if c
(alist-cons 'cores c result) (apply values (alist-cons 'cores c result) rest)
(leave (_ "~a: not a number~%") arg))))))) (leave (_ "~a: not a number~%") arg)))))))

365
guix/scripts/offload.scm
View File

@ -23,7 +23,7 @@
#:use-module (guix derivations) #:use-module (guix derivations)
#:use-module (guix nar) #:use-module (guix nar)
#:use-module (guix utils) #: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 (guix ui)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
@ -122,38 +122,40 @@ determined."
(leave (_ "failed to load machine file '~a': ~s~%") (leave (_ "failed to load machine file '~a': ~s~%")
file args)))))) file args))))))
(define (open-ssh-gateway machine) ;;; FIXME: The idea was to open the connection to MACHINE once for all, but
"Initiate an SSH connection gateway to MACHINE, and return the PID of the ;;; lshg is currently non-functional.
running lsh gateway upon success, or #f on failure." ;; (define (open-ssh-gateway machine)
(catch 'system-error ;; "Initiate an SSH connection gateway to MACHINE, and return the PID of the
(lambda () ;; running lsh gateway upon success, or #f on failure."
(let* ((port (open-pipe* OPEN_READ %lsh-command ;; (catch 'system-error
"-l" (build-machine-user machine) ;; (lambda ()
"-i" (build-machine-private-key machine) ;; (let* ((port (open-pipe* OPEN_READ %lsh-command
;; XXX: With lsh 2.1, passing '--write-pid' ;; "-l" (build-machine-user machine)
;; last causes the PID not to be printed. ;; "-i" (build-machine-private-key machine)
"--write-pid" "--gateway" "--background" "-z" ;; ;; XXX: With lsh 2.1, passing '--write-pid'
(build-machine-name machine))) ;; ;; last causes the PID not to be printed.
(line (read-line port)) ;; "--write-pid" "--gateway" "--background" "-z"
(status (close-pipe port))) ;; (build-machine-name machine)))
(if (zero? status) ;; (line (read-line port))
(let ((pid (string->number line))) ;; (status (close-pipe port)))
(if (integer? pid) ;; (if (zero? status)
pid ;; (let ((pid (string->number line)))
(begin ;; (if (integer? pid)
(warning (_ "'~a' did not write its PID on stdout: ~s~%") ;; pid
%lsh-command line) ;; (begin
#f))) ;; (warning (_ "'~a' did not write its PID on stdout: ~s~%")
(begin ;; %lsh-command line)
(warning (_ "failed to initiate SSH connection to '~a':\ ;; #f)))
'~a' exited with ~a~%") ;; (begin
(build-machine-name machine) ;; (warning (_ "failed to initiate SSH connection to '~a':\
%lsh-command ;; '~a' exited with ~a~%")
(status:exit-val status)) ;; (build-machine-name machine)
#f)))) ;; %lsh-command
(lambda args ;; (status:exit-val status))
(leave (_ "failed to execute '~a': ~a~%") ;; #f))))
%lsh-command (strerror (system-error-errno args)))))) ;; (lambda args
;; (leave (_ "failed to execute '~a': ~a~%")
;; %lsh-command (strerror (system-error-errno args))))))
(define (remote-pipe machine mode command) (define (remote-pipe machine mode command)
"Run COMMAND on MACHINE, assuming an lsh gateway has been set up." "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 () (lambda ()
(apply open-pipe* mode %lshg-command (apply open-pipe* mode %lshg-command
"-l" (build-machine-user machine) "-z" "-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) (build-machine-name machine)
command)) command))
(lambda args (lambda args
@ -168,9 +174,89 @@ running lsh gateway upon success, or #f on failure."
%lshg-command (strerror (system-error-errno args))) %lshg-command (strerror (system-error-errno args)))
#f))) #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 (define* (offload drv machine
#:key print-build-trace? (max-silent-time 3600) #: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 "Perform DRV on MACHINE, assuming DRV and its prerequisites are available
there, and write the build log to LOG-PORT. Return the exit status." there, and write the build log to LOG-PORT. Return the exit status."
(format (current-error-port) "offloading '~a' to '~a'...~%" (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. ;; FIXME: Protect DRV from garbage collection on MACHINE.
(let ((pipe (remote-pipe machine OPEN_READ (let ((pipe (remote-pipe machine OPEN_READ
`("guix" "build" `("guix" "build"
;; FIXME: more options
,(format #f "--max-silent-time=~a" ,(format #f "--max-silent-time=~a"
max-silent-time) max-silent-time)
,@(if build-timeout
(list (format #f "--timeout=~a"
build-timeout))
'())
,(derivation-file-name drv))))) ,(derivation-file-name drv)))))
(let loop ((line (read-line pipe))) (let loop ((line (read-line pipe)))
(unless (eof-object? line) (unless (eof-object? line)
@ -193,6 +282,43 @@ there, and write the build log to LOG-PORT. Return the exit status."
(close-pipe pipe))) (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) (define (send-files files machine)
"Send the subset of FILES that's missing to MACHINE's store. Return #t on "Send the subset of FILES that's missing to MACHINE's store. Return #t on
success, #f otherwise." success, #f otherwise."
@ -256,6 +382,11 @@ success, #f otherwise."
(zero? (close-pipe pipe))))))) (zero? (close-pipe pipe)))))))
;;;
;;; Scheduling.
;;;
(define (machine-matches? machine requirements) (define (machine-matches? machine requirements)
"Return #t if MACHINE matches REQUIREMENTS." "Return #t if MACHINE matches REQUIREMENTS."
(and (string=? (build-requirements-system requirements) (and (string=? (build-requirements-system requirements)
@ -268,57 +399,124 @@ success, #f otherwise."
"Return #t if M1 is faster than M2." "Return #t if M1 is faster than M2."
(> (build-machine-speed m1) (build-machine-speed m2))) (> (build-machine-speed m1) (build-machine-speed m2)))
(define (choose-build-machine requirements machines) (define (machine-load machine)
"Return the best machine among MACHINES fulfilling REQUIREMENTS, or #f." "Return the load of MACHINE, divided by the number of parallel builds
;; FIXME: Take machine load into account, and/or shuffle MACHINES. allowed on MACHINE."
(let ((machines (sort (filter (cut machine-matches? <> requirements) (let* ((pipe (remote-pipe machine OPEN_READ `("cat" "/proc/loadavg")))
machines) (line (read-line pipe)))
machine-faster?))) (close-pipe pipe)
(match machines (if (eof-object? line)
((head . _) 1.
head) (match (string-tokenize line)
(_ #f)))) ((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 (define* (process-request wants-local? system drv features
#:key #:key
print-build-trace? (max-silent-time 3600) print-build-trace? (max-silent-time 3600)
(build-timeout 7200)) build-timeout)
"Process a request to build DRV." "Process a request to build DRV."
(let* ((local? (and wants-local? (string=? system (%current-system)))) (let* ((local? (and wants-local? (string=? system (%current-system))))
(reqs (build-requirements (reqs (build-requirements
(system system) (system system)
(features features))) (features features)))
(machine (choose-build-machine reqs (build-machines)))) (candidates (filter (cut machine-matches? <> reqs)
(if machine (build-machines))))
(match (open-ssh-gateway machine) (match candidates
((? integer? pid) (()
(display "# accept\n") ;; We'll never be able to match REQS.
(let ((inputs (string-tokenize (read-line))) (display "# decline\n"))
(outputs (string-tokenize (read-line)))) ((_ ...)
(when (send-files (cons (derivation-file-name drv) inputs) (let ((machine (choose-build-machine candidates)))
machine) (if machine
(let ((status (offload drv machine (begin
#:print-build-trace? print-build-trace? ;; Offload DRV to MACHINE.
#:max-silent-time max-silent-time (display "# accept\n")
#:build-timeout build-timeout))) (let ((inputs (string-tokenize (read-line)))
(kill pid SIGTERM) (outputs (string-tokenize (read-line))))
(if (zero? status) (transfer-and-offload drv machine
(begin #:inputs inputs
(retrieve-files outputs machine) #:outputs outputs
(format (current-error-port) #:max-silent-time max-silent-time
"done with offloaded '~a'~%" #:build-timeout build-timeout
(derivation-file-name drv))) #:print-build-trace? print-build-trace?)))
(begin
(format (current-error-port) ;; Not now, all the machines are busy.
"derivation '~a' offloaded to '~a' failed \ (display "# postpone\n")))))))
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"))))
(define-syntax-rule (with-nar-error-handling body ...) (define-syntax-rule (with-nar-error-handling body ...)
"Execute BODY with any &nar-error suitably reported to the user." "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 (x
(leave (_ "invalid arguments: ~{~s ~}~%") 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 ;;; offload.scm ends here

210
guix/scripts/package.scm
View File

@ -26,6 +26,7 @@
#:use-module (guix profiles) #:use-module (guix profiles)
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (guix config) #:use-module (guix config)
#:use-module (guix scripts build)
#:use-module ((guix build utils) #:select (directory-exists? mkdir-p)) #:use-module ((guix build utils) #:select (directory-exists? mkdir-p))
#:use-module ((guix ftp-client) #:select (ftp-open)) #:use-module ((guix ftp-client) #:select (ftp-open))
#:use-module (ice-9 format) #: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. ;; Alist of default option values.
`((profile . ,%current-profile) `((profile . ,%current-profile)
(max-silent-time . 3600) (max-silent-time . 3600)
(verbosity . 0)
(substitutes? . #t))) (substitutes? . #t)))
(define (show-help) (define (show-help)
@ -484,18 +486,9 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
(display (_ " (display (_ "
-d, --delete-generations[=PATTERN] -d, --delete-generations[=PATTERN]
delete generations matching PATTERN")) delete generations matching PATTERN"))
(newline)
(display (_ " (display (_ "
-p, --profile=PROFILE use PROFILE instead of the user's default profile")) -p, --profile=PROFILE use PROFILE instead of the user's default profile"))
(display (_ " (newline)
-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"))
(display (_ " (display (_ "
--bootstrap use the bootstrap Guile to build the profile")) --bootstrap use the bootstrap Guile to build the profile"))
(display (_ " (display (_ "
@ -510,6 +503,8 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
-A, --list-available[=REGEXP] -A, --list-available[=REGEXP]
list available packages matching REGEXP")) list available packages matching REGEXP"))
(newline) (newline)
(show-build-options-help)
(newline)
(display (_ " (display (_ "
-h, --help display this help and exit")) -h, --help display this help and exit"))
(display (_ " (display (_ "
@ -519,107 +514,94 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
(define %options (define %options
;; Specification of the command-line options. ;; Specification of the command-line options.
(list (option '(#\h "help") #f #f (cons* (option '(#\h "help") #f #f
(lambda args (lambda args
(show-help) (show-help)
(exit 0))) (exit 0)))
(option '(#\V "version") #f #f (option '(#\V "version") #f #f
(lambda args (lambda args
(show-version-and-exit "guix package"))) (show-version-and-exit "guix package")))
(option '(#\i "install") #f #t (option '(#\i "install") #f #t
(lambda (opt name arg result arg-handler) (lambda (opt name arg result arg-handler)
(let arg-handler ((arg arg) (result result)) (let arg-handler ((arg arg) (result result))
(values (if arg (values (if arg
(alist-cons 'install arg result) (alist-cons 'install arg result)
result) result)
arg-handler)))) arg-handler))))
(option '(#\e "install-from-expression") #t #f (option '(#\e "install-from-expression") #t #f
(lambda (opt name arg result arg-handler) (lambda (opt name arg result arg-handler)
(values (alist-cons 'install (read/eval-package-expression arg) (values (alist-cons 'install (read/eval-package-expression arg)
result) result)
#f))) #f)))
(option '(#\r "remove") #f #t (option '(#\r "remove") #f #t
(lambda (opt name arg result arg-handler) (lambda (opt name arg result arg-handler)
(let arg-handler ((arg arg) (result result)) (let arg-handler ((arg arg) (result result))
(values (if arg (values (if arg
(alist-cons 'remove arg result) (alist-cons 'remove arg result)
result) result)
arg-handler)))) arg-handler))))
(option '(#\u "upgrade") #f #t (option '(#\u "upgrade") #f #t
(lambda (opt name arg result arg-handler) (lambda (opt name arg result arg-handler)
(let arg-handler ((arg arg) (result result)) (let arg-handler ((arg arg) (result result))
(values (alist-cons 'upgrade arg (values (alist-cons 'upgrade arg
;; Delete any prior "upgrade all" ;; Delete any prior "upgrade all"
;; command, or else "--upgrade gcc" ;; command, or else "--upgrade gcc"
;; would upgrade everything. ;; would upgrade everything.
(delete '(upgrade . #f) result)) (delete '(upgrade . #f) result))
arg-handler)))) arg-handler))))
(option '("roll-back") #f #f (option '("roll-back") #f #f
(lambda (opt name arg result arg-handler) (lambda (opt name arg result arg-handler)
(values (alist-cons 'roll-back? #t result) (values (alist-cons 'roll-back? #t result)
#f))) #f)))
(option '(#\l "list-generations") #f #t (option '(#\l "list-generations") #f #t
(lambda (opt name arg result arg-handler) (lambda (opt name arg result arg-handler)
(values (cons `(query list-generations ,(or arg "")) (values (cons `(query list-generations ,(or arg ""))
result) result)
#f))) #f)))
(option '(#\d "delete-generations") #f #t (option '(#\d "delete-generations") #f #t
(lambda (opt name arg result arg-handler) (lambda (opt name arg result arg-handler)
(values (alist-cons 'delete-generations (or arg "") (values (alist-cons 'delete-generations (or arg "")
result) result)
#f))) #f)))
(option '("search-paths") #f #f (option '("search-paths") #f #f
(lambda (opt name arg result arg-handler) (lambda (opt name arg result arg-handler)
(values (cons `(query search-paths) result) (values (cons `(query search-paths) result)
#f))) #f)))
(option '(#\p "profile") #t #f (option '(#\p "profile") #t #f
(lambda (opt name arg result arg-handler) (lambda (opt name arg result arg-handler)
(values (alist-cons 'profile arg (values (alist-cons 'profile arg
(alist-delete 'profile result)) (alist-delete 'profile result))
#f))) #f)))
(option '(#\n "dry-run") #f #f (option '(#\n "dry-run") #f #f
(lambda (opt name arg result arg-handler) (lambda (opt name arg result arg-handler)
(values (alist-cons 'dry-run? #t result) (values (alist-cons 'dry-run? #t result)
#f))) #f)))
(option '("fallback") #f #f (option '("bootstrap") #f #f
(lambda (opt name arg result arg-handler) (lambda (opt name arg result arg-handler)
(values (alist-cons 'fallback? #t (values (alist-cons 'bootstrap? #t result)
(alist-delete 'fallback? result)) #f)))
#f))) (option '("verbose") #f #f
(option '("no-substitutes") #f #f (lambda (opt name arg result arg-handler)
(lambda (opt name arg result arg-handler) (values (alist-cons 'verbose? #t result)
(values (alist-cons 'substitutes? #f #f)))
(alist-delete 'substitutes? result)) (option '(#\s "search") #t #f
#f))) (lambda (opt name arg result arg-handler)
(option '("max-silent-time") #t #f (values (cons `(query search ,(or arg ""))
(lambda (opt name arg result arg-handler) result)
(values (alist-cons 'max-silent-time (string->number* arg) #f)))
result) (option '(#\I "list-installed") #f #t
#f))) (lambda (opt name arg result arg-handler)
(option '("bootstrap") #f #f (values (cons `(query list-installed ,(or arg ""))
(lambda (opt name arg result arg-handler) result)
(values (alist-cons 'bootstrap? #t result) #f)))
#f))) (option '(#\A "list-available") #f #t
(option '("verbose") #f #f (lambda (opt name arg result arg-handler)
(lambda (opt name arg result arg-handler) (values (cons `(query list-available ,(or arg ""))
(values (alist-cons 'verbose? #t result) result)
#f))) #f)))
(option '(#\s "search") #t #f
(lambda (opt name arg result arg-handler) %standard-build-options))
(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)))))
(define (options->installable opts manifest) (define (options->installable opts manifest)
"Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold', "Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold',
@ -1052,13 +1034,7 @@ more information.~%"))
(or (process-query opts) (or (process-query opts)
(with-error-handling (with-error-handling
(parameterize ((%store (open-connection))) (parameterize ((%store (open-connection)))
(set-build-options (%store) (set-build-options-from-command-line (%store) opts)
#:print-build-trace #f
#:fallback? (assoc-ref opts 'fallback?)
#:use-substitutes?
(assoc-ref opts 'substitutes?)
#:max-silent-time
(assoc-ref opts 'max-silent-time))
(parameterize ((%guile-for-build (parameterize ((%guile-for-build
(package-derivation (%store) (package-derivation (%store)

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

@ -38,6 +38,7 @@
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
#:use-module (srfi srfi-19) #:use-module (srfi srfi-19)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (web uri) #:use-module (web uri)
#:use-module (guix http-client) #:use-module (guix http-client)
#:export (guix-substitute-binary)) #:export (guix-substitute-binary))
@ -133,33 +134,38 @@ provide."
(if buffered? "rb" "r0b")))) (if buffered? "rb" "r0b"))))
(values port (stat:size (stat port))))) (values port (stat:size (stat port)))))
((http) ((http)
;; On Guile 2.0.5, `http-fetch' fetches the whole thing at once. So (guard (c ((http-get-error? c)
;; honor TIMEOUT? to disable the timeout when fetching a nar. (leave (_ "download from '~a' failed: ~a, ~s~%")
;; (uri->string (http-get-error-uri c))
;; Test this with: (http-get-error-code c)
;; sudo tc qdisc add dev eth0 root netem delay 1500ms (http-get-error-reason c))))
;; and then cancel with: ;; On Guile 2.0.5, `http-fetch' fetches the whole thing at once. So
;; sudo tc qdisc del dev eth0 root ;; honor TIMEOUT? to disable the timeout when fetching a nar.
(let ((port #f)) ;;
(with-timeout (if (or timeout? (guile-version>? "2.0.5")) ;; Test this with:
%fetch-timeout ;; sudo tc qdisc add dev eth0 root netem delay 1500ms
0) ;; and then cancel with:
(begin ;; sudo tc qdisc del dev eth0 root
(warning (_ "while fetching ~a: server is unresponsive~%") (let ((port #f))
(uri->string uri)) (with-timeout (if (or timeout? (guile-version>? "2.0.5"))
(warning (_ "try `--no-substitutes' if the problem persists~%")) %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, ;; 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 ;; and thus PORT had to be closed and re-opened. This is not the
;; case afterward. ;; case afterward.
(unless (or (guile-version>? "2.0.9") (unless (or (guile-version>? "2.0.9")
(version>? (version) "2.0.9.39")) (version>? (version) "2.0.9.39"))
(when port (when port
(close-port port)))) (close-port port))))
(begin (begin
(when (or (not port) (port-closed? port)) (when (or (not port) (port-closed? port))
(set! port (open-socket-for-uri uri #:buffered? buffered?))) (set! port (open-socket-for-uri uri #:buffered? buffered?)))
(http-fetch uri #:text? #f #:port port))))))) (http-fetch uri #:text? #f #:port port))))))))
(define-record-type <cache> (define-record-type <cache>
(%make-cache url store-directory wants-mass-query?) (%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 ;;; 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. ;;; This file is part of GNU Guix.
;;; ;;;
@ -22,11 +22,13 @@
#:use-module (rnrs io ports) #:use-module (rnrs io ports)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:export (write-int read-int #:export (write-int read-int
write-long-long read-long-long write-long-long read-long-long
write-padding write-padding
write-string read-string read-latin1-string write-string read-string read-latin1-string
write-string-list read-string-list write-string-list read-string-list
write-string-pairs
write-store-path read-store-path write-store-path read-store-path
write-store-path-list read-store-path-list)) write-store-path-list read-store-path-list))
@ -94,6 +96,14 @@
(write-int (length l) p) (write-int (length l) p)
(for-each (cut write-string <> p) l)) (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) (define (read-string-list p)
(let ((len (read-int p))) (let ((len (read-int p)))
(unfold (cut >= <> len) (unfold (cut >= <> len)

25
guix/store.scm
View File

@ -197,7 +197,7 @@
result)))))) result))))))
(define-syntax write-arg (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) store-path store-path-list base16)
((_ integer arg p) ((_ integer arg p)
(write-int arg p)) (write-int arg p))
@ -209,6 +209,8 @@
(write-string arg p)) (write-string arg p))
((_ string-list arg p) ((_ string-list arg p)
(write-string-list arg p)) (write-string-list arg p))
((_ string-pairs arg p)
(write-string-pairs arg p))
((_ store-path arg p) ((_ store-path arg p)
(write-store-path arg p)) (write-store-path arg p))
((_ store-path-list arg p) ((_ store-path-list arg p)
@ -430,6 +432,7 @@ encoding conversion errors."
#:key keep-failed? keep-going? fallback? #:key keep-failed? keep-going? fallback?
(verbosity 0) (verbosity 0)
(max-build-jobs (current-processor-count)) (max-build-jobs (current-processor-count))
timeout
(max-silent-time 3600) (max-silent-time 3600)
(use-build-hook? #t) (use-build-hook? #t)
(build-verbosity 0) (build-verbosity 0)
@ -462,12 +465,11 @@ encoding conversion errors."
(when (>= (nix-server-minor-version server) 10) (when (>= (nix-server-minor-version server) 10)
(send (boolean use-substitutes?))) (send (boolean use-substitutes?)))
(when (>= (nix-server-minor-version server) 12) (when (>= (nix-server-minor-version server) 12)
(send (string-list (fold-right (lambda (pair result) (let ((pairs (if timeout
(match pair `(("build-timeout" . ,(number->string timeout))
((h . t) ,@binary-caches)
(cons* h t result)))) binary-caches)))
'() (send (string-pairs pairs))))
binary-caches))))
(let loop ((done? (process-stderr server))) (let loop ((done? (process-stderr server)))
(or 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)) (define* (export-paths server paths port #:key (sign? #t))
"Export the store paths listed in PATHS to PORT, in topological order, "Export the store paths listed in PATHS to PORT, in topological order,
signing them if SIGN? is true." 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 ((s (nix-server-socket server)))
(let loop ((paths (topologically-sorted server paths))) (let loop ((paths ordered))
(match paths (match paths
(() (()
(write-int 0 port)) (write-int 0 port))
@ -822,7 +829,7 @@ must be an absolute store file name, or a derivation file name."
(cond ((derivation-path? file) (cond ((derivation-path? file)
(let* ((base (basename file)) (let* ((base (basename file))
(log (string-append (dirname %state-directory) ; XXX (log (string-append (dirname %state-directory) ; XXX
"/log/nix/drvs/" "/log/guix/drvs/"
(string-take base 2) "/" (string-take base 2) "/"
(string-drop base 2))) (string-drop base 2)))
(log.bz2 (string-append log ".bz2"))) (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 ((string-contains %host-type "linux") 7) ; *-linux-gnu
(else 9)))) ; *-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 (define F_xxLCK
;; The F_RDLCK, F_WRLCK, and F_UNLCK constants. ;; The F_RDLCK, F_WRLCK, and F_UNLCK constants.
(compile-time-value (compile-time-value
@ -252,12 +259,30 @@ buffered data is lost."
((string-contains %host-type "linux") #(0 1 2)) ; *-linux-gnu ((string-contains %host-type "linux") #(0 1 2)) ; *-linux-gnu
(else #(1 2 3))))) ; *-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 (define fcntl-flock
(let* ((ptr (dynamic-func "fcntl" (dynamic-link))) (let* ((ptr (dynamic-func "fcntl" (dynamic-link)))
(proc (pointer->procedure int ptr `(,int ,int *)))) (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 "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) (define (operation->int op)
(case op (case op
((read-lock) (vector-ref F_xxLCK 0)) ((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 ;; XXX: 'fcntl' is a vararg function, but here we happily use the
;; standard ABI; crossing fingers. ;; standard ABI; crossing fingers.
(let ((err (proc fd (let ((err (proc fd
F_SETLKW ; lock & wait (if wait?
F_SETLKW ; lock & wait
F_SETLK) ; non-blocking attempt
(make-c-struct %struct-flock (make-c-struct %struct-flock
(list (operation->int operation) (list (operation->int operation)
SEEK_SET SEEK_SET
@ -282,7 +309,7 @@ must be a symbol, one of 'read-lock, 'write-lock, or 'unlock."
(or (zero? err) (or (zero? err)
;; Presumably we got EAGAIN or so. ;; 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)) (build-derivations store (list drv))
#f))) #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" (test-assert "build-expression->derivation and derivation-prerequisites-to-build"
(let ((drv (build-expression->derivation %store "fail" #f))) (let ((drv (build-expression->derivation %store "fail" #f)))
;; The only direct dependency is (%guile-for-build) and it's already ;; 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))) (s1 (topologically-sorted %store (list y)))
(s2 (topologically-sorted %store (list c y))) (s2 (topologically-sorted %store (list c y)))
(s3 (topologically-sorted %store (cons y (references %store y))))) (s3 (topologically-sorted %store (cons y (references %store y)))))
(and (equal? s1 (list w x a b c d y)) ;; The order in which 'references' returns the references of Y is
(equal? s2 (list a b c w x d y)) ;; unspecified, so accommodate.
(lset= string=? s1 s3)))) (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" (test-assert "log-file, derivation"
(let* ((b (add-text-to-store %store "build" "echo $foo > $out" '())) (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
@ -399,7 +408,9 @@ Deriver: ~a~%"
files))))))) files)))))))
(test-assert "export/import paths, ensure topological order" (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) (file2 (add-text-to-store %store "bar" (random-text)
(list file1))) (list file1)))
(files (list file1 file2)) (files (list file1 file2))
@ -412,9 +423,10 @@ Deriver: ~a~%"
(bytevector=? dump1 dump2) (bytevector=? dump1 dump2)
(let* ((source (open-bytevector-input-port dump1)) (let* ((source (open-bytevector-input-port dump1))
(imported (import-paths %store source))) (imported (import-paths %store source)))
;; DUMP1 should contain exactly FILE1 and FILE2, not FILE0.
(and (equal? imported (list file1 file2)) (and (equal? imported (list file1 file2))
(every file-exists? files) (every file-exists? files)
(null? (references %store file1)) (equal? (list file0) (references %store file1))
(equal? (list file1) (references %store file2))))))) (equal? (list file1) (references %store file2)))))))
(test-assert "import corrupt path" (test-assert "import corrupt path"

87
tests/utils.scm
View File

@ -27,6 +27,9 @@
#:use-module (rnrs io ports) #:use-module (rnrs io ports)
#:use-module (ice-9 match)) #:use-module (ice-9 match))
(define temp-file
(string-append "t-utils-" (number->string (getpid))))
(test-begin "utils") (test-begin "utils")
(test-assert "bytevector->base16-string->bytevector" (test-assert "bytevector->base16-string->bytevector"
@ -139,36 +142,88 @@
(append pids1 pids2))) (append pids1 pids2)))
(equal? (get-bytevector-all decompressed) data))))) (equal? (get-bytevector-all decompressed) data)))))
(test-equal "fcntl-flock" (false-if-exception (delete-file temp-file))
0 ; the child's exit status (test-equal "fcntl-flock wait"
(let ((file (open-input-file (search-path %load-path "guix.scm")))) 42 ; the child's exit status
(fcntl-flock file 'read-lock) (let ((file (open-file temp-file "w0")))
;; Acquire an exclusive lock.
(fcntl-flock file 'write-lock)
(match (primitive-fork) (match (primitive-fork)
(0 (0
(dynamic-wind (dynamic-wind
(const #t) (const #t)
(lambda () (lambda ()
;; Taking a read lock should be OK. ;; Reopen FILE read-only so we can have a read lock.
(fcntl-flock file 'read-lock) (let ((file (open-file temp-file "r")))
(fcntl-flock file 'unlock) ;; Wait until we can acquire the lock.
(fcntl-flock file 'read-lock)
(catch 'flock-error (primitive-exit (read file)))
(lambda ()
;; Taking an exclusive lock should raise an exception.
(fcntl-flock file 'write-lock))
(lambda args
(primitive-exit 0)))
(primitive-exit 1)) (primitive-exit 1))
(lambda () (lambda ()
(primitive-exit 2)))) (primitive-exit 2))))
(pid (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) (match (waitpid pid)
((_ . status) ((_ . status)
(let ((result (status:exit-val status))) (let ((result (status:exit-val status)))
(fcntl-flock file 'unlock)
(close-port file) (close-port file)
result))))))) 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). ;; This is actually in (guix store).
(test-equal "store-path-package-name" (test-equal "store-path-package-name"
"bash-4.2-p24" "bash-4.2-p24"
@ -178,5 +233,7 @@
(test-end) (test-end)
(false-if-exception (delete-file temp-file))
(exit (= (test-runner-fail-count (test-runner-current)) 0)) (exit (= (test-runner-fail-count (test-runner-current)) 0))