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-01-08 22:06:54 +01:00
parent aa6b0d6bf0 1d6816f98c
commit 2f265602ff
62 changed files with 2509 additions and 429 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.dir-locals.el
View File

@ -20,6 +20,7 @@
(eval . (put 'substitute-keyword-arguments 'scheme-indent-function 1))
(eval . (put 'with-error-handling 'scheme-indent-function 0))
(eval . (put 'with-mutex 'scheme-indent-function 1))
(eval . (put 'with-atomic-file-output 'scheme-indent-function 1))
(eval . (put 'syntax-parameterize 'scheme-indent-function 1))
(eval . (put 'with-monad 'scheme-indent-function 1))

1
.gitignore vendored
View File

@ -84,3 +84,4 @@ GPATH
GRTAGS
GTAGS
/nix-setuid-helper
/nix/scripts/guix-authenticate

12
Makefile.am
View File

@ -30,6 +30,8 @@ MODULES = \
guix/base32.scm \
guix/records.scm \
guix/hash.scm \
guix/pk-crypto.scm \
guix/pki.scm \
guix/utils.scm \
guix/download.scm \
guix/monads.scm \
@ -66,12 +68,14 @@ MODULES = \
guix/snix.scm \
guix/scripts/download.scm \
guix/scripts/build.scm \
guix/scripts/archive.scm \
guix/scripts/import.scm \
guix/scripts/package.scm \
guix/scripts/gc.scm \
guix/scripts/hash.scm \
guix/scripts/pull.scm \
guix/scripts/substitute-binary.scm \
guix/scripts/authenticate.scm \
guix/scripts/refresh.scm \
guix.scm \
$(GNU_SYSTEM_MODULES)
@ -107,6 +111,8 @@ clean-go:
SCM_TESTS = \
tests/base32.scm \
tests/hash.scm \
tests/pk-crypto.scm \
tests/pki.scm \
tests/builders.scm \
tests/derivations.scm \
tests/ui.scm \
@ -126,7 +132,9 @@ SH_TESTS = \
tests/guix-download.sh \
tests/guix-gc.sh \
tests/guix-hash.sh \
tests/guix-package.sh
tests/guix-package.sh \
tests/guix-archive.sh \
tests/guix-authenticate.sh
if BUILD_DAEMON
@ -170,6 +178,8 @@ EXTRA_DIST = \
srfi/srfi-64.scm \
srfi/srfi-64.upstream.scm \
tests/test.drv \
tests/signing-key.pub \
tests/signing-key.sec \
build-aux/config.rpath \
bootstrap \
release.nix \

14
ROADMAP
View File

@ -2,7 +2,7 @@
#+TITLE: Tentative GNU Guix Road Map
Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
Copying and distribution of this file, with or without modification,
are permitted in any medium without royalty provided the copyright
@ -15,10 +15,18 @@ The goals of the GNU Guix project are two-fold:
- to use it to build a practical 100% free software distribution of
GNU/Linux and possibly other GNU variants, with a focus on the
promotion and tight integration of GNU components.
promotion and tight integration of GNU components–the GNU system.
This documents lists tentative milestones toward these goals.
This document lists milestones toward these goals.
The timeline below was written at the end of Dec. 2012. An updated and more
detailed list of the remaining milestones was posted at
https://lists.gnu.org/archive/html/guix-devel/2013-12/msg00120.html .
The actual timeline was of course slightly different than initially
envisioned, and so was the feature set–things like cross-compilation support
and the MIPS64 port were not planned back then. See the news section at
http://www.gnu.org/software/guix/ and ‘NEWS’ for the release history.
* GNU Guix 0.1: Jan. 2013 (was: Dec. 2012)

2
THANKS
View File

@ -15,7 +15,9 @@ infrastructure help:
Rafael Ferreira <rafael.f.f1@gmail.com>
Christian Grothoff <christian@grothoff.org>
Jeffrin Jose <ahiliation@yahoo.co.in>
Kete <kete@ninthfloor.org>
Matthew Lien <bluet@bluet.org>
Niels Möller <nisse@lysator.liu.se>
Yutaka Niibe <gniibe@fsij.org>
Cyrill Schenkel <cyrill.schenkel@gmail.com>
Jason Self <jself@gnu.org>

73
TODO
View File

@ -11,23 +11,6 @@ Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
* integrate needed Nix code
** Remove dependency on OpenSSL
The ‘openssl’ command-line tool is used in libstore to sign store paths
to be exported, and to check such signatures. The signing keys are
usually in /etc/nix/signing-key.{pub,sec}. They are a PKCS#8-encoded
X.509 SubjectPublicKeyInfo. These can be decoded with the [[http://lists.gnu.org/archive/html/help-gnutls/2012-12/msg00012.html][C API of
GnuTLS]], but not yet with its Guile bindings. There’s also
‘gnutls_privkey_sign_data’ to sign, and related functions.
** Add `guix publish' to publish the store using Guile's web server
Generate narinfos and nars on the fly, upon HTTP GET requests.
Ideally, extend .nix-cache-info to include the server's public key, and also
reply to requests for .narinfo.sig.
Optionally, use Guile-Avahi to publish the service.
** MAYBE Add a substituter that uses the GNUnet DHT or [[http://libswift.org][libswift]]
Would be neat if binaries could be pushed to and pulled from the GNUnet DHT or
@ -40,6 +23,13 @@ Use UPnP and similar to traverse NAT, like ‘filegive’ does.
Like scripts/build-remote.pl in Nix.
* Add `guix publish' to publish the store using Guile's web server
Generate narinfos and nars on the fly, upon HTTP GET requests.
Ideally, extend .nix-cache-info to include the server's public key, and also
reply to requests for .narinfo.sig.
Optionally, use Guile-Avahi to publish the service.
* user interface
** Add a package.el (Emacs) back-end
@ -48,17 +38,6 @@ package.el is quite monolithic, but we may be able to reuse/extend
** add guile-ncurses interface
* extend <origin>
** add OpenPGP signatures:
(origin
(method http-fetch)
(uri "http://.../foo.tgz")
(signature-uri (string-append uri ".sig"))
(signer-openpgp-fingerprint "..."))
** allow <origin> to be a derivation/package or a file
* extend <package>
** add ‘recommends’ field
@ -84,28 +63,45 @@ create a new ‘dir’.
("i3" ,p3)))
#+END_SRC
* MAYBE use HOP-like escapes to refer to inputs in build-side code
* synchronize package descriptions with GSRC and/or the [[http://directory.fsf.org][FSD]]
Instead of doing things like:
#+BEGIN_SRC scheme
(inputs `(("foo" ,foo)))
(arguments '(#:configure-flags
(list (string-append "--with-foo="
(assoc-ref %build-inputs "foo")))))
#+END_SRC
Allow things like:
#+BEGIN_SRC scheme
(inputs (list foo))
(arguments ~(#:configure-flags
(list (string-append "--with-foo=" $foo))))
#+END_SRC
... where '~' is 'build-quote' and '$' is 'build-unquote'. Better yet,
automatically compute the list of references of an expression passed to
'derivation-expression'.
Use a [[http://dorophone.blogspot.fr/2011/09/scheme-syntax-is-monad.html][monad]] for the syntax.
* synchronize non-GNU package descriptions with the [[http://directory.fsf.org][FSD]]
Meta-data for GNU packages, including descriptions and synopses, can be
dumped from the FSD:
http://directory.fsf.org/wiki?title=GNU/Export&action=purge .
We could periodically synchronize with that.
See http://lists.gnu.org/archive/html/bug-guix/2013-04/msg00120.html for info
on how to synchronize with GSRC's descriptions.
* add a guildhall build system
The Guildhall is Guile’s packaging system. It should be easy to add a
‘guildhall-build-system’ that does the right thing based on guildhall
recipes.
* build-expression->derivation: define `%system' in the builder
Would allow build expressions to have system-dependent code, like
`glibc-dynamic-linker'.
* add ‘allowed-references’ in <package>
[[file:~/src/nix/src/libstore/build.cc::if%20(drv.env.find("allowedReferences")%20!%3D%20drv.env.end())%20{][See how Nix implements that internally]].
@ -126,9 +122,6 @@ run when that is defined.
Would download a substitute, and compare its contents against a (hopefully
locally-built) copy.
* guix package
** add ‘--list-generations’, and ‘--delete-generations’
* guix build utils
** MAYBE Change ‘ld-wrapper’ to add RPATH for libs passed by file name

2
config-daemon.ac
View File

@ -105,6 +105,8 @@ if test "x$guix_build_daemon" = "xyes"; then
[chmod +x nix/scripts/list-runtime-roots])
AC_CONFIG_FILES([nix/scripts/substitute-binary],
[chmod +x nix/scripts/substitute-binary])
AC_CONFIG_FILES([nix/scripts/guix-authenticate],
[chmod +x nix/scripts/guix-authenticate])
fi
AM_CONDITIONAL([BUILD_DAEMON], [test "x$guix_build_daemon" = "xyes"])

10
configure.ac
View File

@ -36,10 +36,12 @@ AC_ARG_ENABLE([daemon],
[guix_build_daemon="$enableval"],
[guix_build_daemon="yes"])
# Prepare a version of $localstatedir that does not contain references
# Prepare a version of $localstatedir & co. that does not contain references
# to shell variables.
guix_localstatedir="`eval echo $localstatedir | sed -e "s|NONE|/usr/local|g"`"
guix_sysconfdir="`eval echo $sysconfdir | sed -e "s|NONE|/usr/local|g"`"
AC_SUBST([guix_localstatedir])
AC_SUBST([guix_sysconfdir])
dnl We require the pkg.m4 set of macros from pkg-config.
dnl Make sure it's available.
@ -60,7 +62,8 @@ GUIX_CHECK_SRFI_37
AM_CONDITIONAL([INSTALL_SRFI_37], [test "x$ac_cv_guix_srfi_37_broken" = xyes])
AC_ARG_WITH([nix-prefix],
[AS_HELP_STRING([--with-nix-prefix=DIR], [search for Nix in DIR])],
[AS_HELP_STRING([--with-nix-prefix=DIR],
[search for Nix in DIR (for testing purposes and '--disable-daemon' builds)])],
[case "$withval" in
yes|no) ;;
*)
@ -84,7 +87,8 @@ if test "x$NIX_INSTANTIATE" = "x"; then
fi
AC_ARG_WITH([nixpkgs],
[AS_HELP_STRING([--with-nixpkgs=DIR], [search for Nixpkgs in DIR])],
[AS_HELP_STRING([--with-nixpkgs=DIR],
[search for Nixpkgs in DIR (for testing purposes only)])],
[case "$withval" in
yes|no) AC_MSG_ERROR([Please use `--with-nixpkgs=DIR'.]);;
*) NIXPKGS="$withval";;

8
daemon.am
View File

@ -112,10 +112,10 @@ libstore_a_CPPFLAGS = \
-DNIX_DATA_DIR=\"$(datadir)\" \
-DNIX_STATE_DIR=\"$(localstatedir)/nix\" \
-DNIX_LOG_DIR=\"$(localstatedir)/log/nix\" \
-DNIX_CONF_DIR=\"$(sysconfdir)/nix\" \
-DNIX_CONF_DIR=\"$(sysconfdir)/guix\" \
-DNIX_LIBEXEC_DIR=\"$(libexecdir)\" \
-DNIX_BIN_DIR=\"$(bindir)\" \
-DOPENSSL_PATH="\"openssl\""
-DOPENSSL_PATH="\"guix-authenticate\""
libstore_a_CXXFLAGS = \
$(SQLITE3_CFLAGS) $(LIBGCRYPT_CFLAGS)
@ -180,6 +180,10 @@ nodist_pkglibexec_SCRIPTS = \
nix/scripts/list-runtime-roots \
nix/scripts/substitute-binary
# XXX: It'd be better to hide it in $(pkglibexecdir).
nodist_libexec_SCRIPTS = \
nix/scripts/guix-authenticate
EXTRA_DIST += \
nix/sync-with-upstream \
nix/libstore/schema.sql \

117
doc/guix.texi
View File

@ -10,7 +10,7 @@
@include version.texi
@copying
Copyright @copyright{} 2012, 2013 Ludovic Courtès@*
Copyright @copyright{} 2012, 2013, 2014 Ludovic Courtès@*
Copyright @copyright{} 2013 Andreas Enge@*
Copyright @copyright{} 2013 Nikita Karetnikov
@ -213,7 +213,8 @@ Bash syntax and the @code{shadow} commands):
do
useradd -g guix-builder -G guix-builder \
-d /var/empty -s `which nologin` \
-c "Guix build user $i" guix-builder$i;
-c "Guix build user $i" --system \
guix-builder$i;
done
@end example
@ -236,6 +237,14 @@ case, shared memory support is unavailable in the chroot environment.
The workaround is to make sure that @file{/dev/shm} is directly a
@code{tmpfs} mount point.}.
Finally, you may want to generate a key pair to allow the daemon to
export signed archives of files from the store (@pxref{Invoking guix
archive}):
@example
# guix archive --generate-key
@end example
Guix may also be used in a single-user setup, with @command{guix-daemon}
running as an unprivileged user. However, to maximize non-interference
of build processes, the daemon still needs to perform certain operations
@ -410,6 +419,7 @@ management tools it provides.
* Packages with Multiple Outputs:: Single source package, multiple outputs.
* Invoking guix gc:: Running the garbage collector.
* Invoking guix pull:: Fetching the latest Guix and distribution.
* Invoking guix archive:: Exporting and importing store files.
@end menu
@node Features
@ -914,6 +924,103 @@ Use the bootstrap Guile to build the latest Guix. This option is only
useful to Guix developers.
@end table
@node Invoking guix archive
@section Invoking @command{guix archive}
The @command{guix archive} command allows users to @dfn{export} files
from the store into a single archive, and to later @dfn{import} them.
In particular, it allows store files to be transferred from one machine
to another machine's store. For example, to transfer the @code{emacs}
package to a machine connected over SSH, one would run:
@example
guix archive --export emacs | ssh the-machine guix archive --import
@end example
@noindent
However, note that, in this example, all of @code{emacs} and its
dependencies are transferred, regardless of what is already available in
the target machine's store. The @code{--missing} option can help figure
out which items are missing from the target's store.
Archives are stored in the ``Nix archive'' or ``Nar'' format, which is
comparable in spirit to `tar'. When exporting, the daemon digitally
signs the contents of the archive, and that digital signature is
appended. When importing, the daemon verifies the signature and rejects
the import in case of an invalid signature or if the signing key is not
authorized.
@c FIXME: Add xref to daemon doc about signatures.
The main options are:
@table @code
@item --export
Export the specified store files or packages (see below.) Write the
resulting archive to the standard output.
@item --import
Read an archive from the standard input, and import the files listed
therein into the store. Abort if the archive has an invalid digital
signature, or if it is signed by a public key not among the authorized
keys (see @code{--authorize} below.)
@item --missing
Read a list of store file names from the standard input, one per line,
and write on the standard output the subset of these files missing from
the store.
@item --generate-key[=@var{parameters}]
@cindex signing, archives
Generate a new key pair for the daemons. This is a prerequisite before
archives can be exported with @code{--export}. Note that this operation
usually takes time, because it needs to gather enough entropy to
generate the key pair.
The generated key pair is typically stored under @file{/etc/guix}, in
@file{signing-key.pub} (public key) and @file{signing-key.sec} (private
key, which must be kept secret.) When @var{parameters} is omitted, it
is a 4096-bit RSA key. Alternately, @var{parameters} can specify
@code{genkey} parameters suitable for Libgcrypt (@pxref{General
public-key related Functions, @code{gcry_pk_genkey},, gcrypt, The
Libgcrypt Reference Manual}).
@item --authorize
@cindex authorizing, archives
Authorize imports signed by the public key passed on standard input.
The public key must be in ``s-expression advanced format''---i.e., the
same format as the @file{signing-key.pub} file.
The list of authorized keys is kept in the human-editable file
@file{/etc/guix/acl}. The file contains
@url{http://people.csail.mit.edu/rivest/Sexp.txt, ``advanced-format
s-expressions''} and is structured as an access-control list in the
@url{http://theworld.com/~cme/spki.txt, Simple Public-Key Infrastructure
(SPKI)}.
@end table
To export store files as an archive to the standard output, run:
@example
guix archive --export @var{options} @var{specifications}...
@end example
@var{specifications} may be either store file names or package
specifications, as for @command{guix package} (@pxref{Invoking guix
package}). For instance, the following command creates an archive
containing the @code{gui} output of the @code{git} package and the main
output of @code{emacs}:
@example
guix archive --export git:gui /nix/store/...-emacs-24.3 > great.nar
@end example
If the specified packages are not built yet, @command{guix archive}
automatically builds them. The build process may be controlled with the
same options that can be passed to the @command{guix build} command
(@pxref{Invoking guix build}).
@c *********************************************************************
@node Programming Interface
@chapter Programming Interface
@ -1559,6 +1666,12 @@ packages locally.
Do not use substitutes for build products. That is, always build things
locally instead of allowing downloads of pre-built binaries.
@item --no-build-hook
Do not attempt to offload builds @i{via} the daemon's ``build hook''.
That is, always build things locally instead of offloading builds to
remote machines.
@c TODO: Add xref to build hook doc.
@item --max-silent-time=@var{seconds}
When the build or substitution process remains silent for more than
@var{seconds}, terminate it and report a build failure.

4
gnu-system.am
View File

@ -63,6 +63,7 @@ GNU_SYSTEM_MODULES = \
gnu/packages/fonts.scm \
gnu/packages/fontutils.scm \
gnu/packages/freeipmi.scm \
gnu/packages/games.scm \
gnu/packages/gawk.scm \
gnu/packages/gcal.scm \
gnu/packages/gcc.scm \
@ -254,6 +255,8 @@ dist_patch_DATA = \
gnu/packages/patches/guile-linux-syscalls.patch \
gnu/packages/patches/guile-relocatable.patch \
gnu/packages/patches/guix-test-networking.patch \
gnu/packages/patches/gtkglext-disable-disable-deprecated.patch \
gnu/packages/patches/gtkglext-remove-pangox-dependency.patch \
gnu/packages/patches/hop-bigloo-4.0b.patch \
gnu/packages/patches/libevent-dns-tests.patch \
gnu/packages/patches/libffi-mips-n32-fix.patch \
@ -273,6 +276,7 @@ dist_patch_DATA = \
gnu/packages/patches/procps-make-3.82.patch \
gnu/packages/patches/pspp-tests.patch \
gnu/packages/patches/pulseaudio-test-timeouts.patch \
gnu/packages/patches/pulseaudio-volume-test.patch \
gnu/packages/patches/python-fix-dbm.patch \
gnu/packages/patches/qemu-make-4.0.patch \
gnu/packages/patches/qemu-multiple-smb-shares.patch \

17
gnu/packages.scm
View File

@ -33,6 +33,7 @@
%bootstrap-binaries-path
fold-packages
find-packages-by-name
find-best-packages-by-name
find-newest-available-packages))
;;; Commentary:
@ -148,7 +149,9 @@ then only return packages whose version is equal to VERSION."
result))
'()))
(define (find-newest-available-packages)
(define find-newest-available-packages
(memoize
(lambda ()
"Return a vhash keyed by package names, and with
associated values of the form
@ -168,4 +171,14 @@ where the preferred package is listed first."
((=) (vhash-cons name `(,version ,p ,@pkgs) r))
((<) r)))
(#f (vhash-cons name `(,version ,p) r)))))
vlist-null))
vlist-null))))
(define (find-best-packages-by-name name version)
"If version is #f, return the list of packages named NAME with the highest
version numbers; otherwise, return the list of packages named NAME and at
VERSION."
(if version
(find-packages-by-name name version)
(match (vhash-assoc name (find-newest-available-packages))
((_ version pkgs ...) pkgs)
(#f '()))))

4
gnu/packages/autotools.scm
View File

@ -132,14 +132,14 @@ exec ~a --no-auto-compile \"$0\" \"$@\"
(define-public automake
(package
(name "automake")
(version "1.14")
(version "1.14.1")
(source (origin
(method url-fetch)
(uri (string-append "mirror://gnu/automake/automake-"
version ".tar.xz"))
(sha256
(base32
"0nc0zqq8j336kamizzd86wb19vhbwywv5avcjh3cyx230xfqy671"))
"0s86rzdayj1licgj35q0mnynv5xa8f4p32m36blc5jk9id5z1d59"))
(patches
(list (search-patch "automake-skip-amhello-tests.patch")))))
(build-system gnu-build-system)

8
gnu/packages/cdrom.scm
View File

@ -68,14 +68,14 @@ caching facility provided by the library.")
(define-public libcdio
(package
(name "libcdio")
(version "0.90")
(version "0.92")
(source (origin
(method url-fetch)
(uri (string-append "mirror://gnu/libcdio/libcdio-"
version ".tar.gz"))
(sha256
(base32
"0kpp6gr5sjr30pb9klncc37fhkw0wi6r41d2fmvmw17cbj176zmg"))))
"1b9zngn8nnxb1yyngi1kwi73nahp4lsx59j17q1bahzz58svydik"))))
(build-system gnu-build-system)
(inputs
`(("ncurses" ,ncurses)
@ -98,14 +98,14 @@ extraction from CDs.")
(define-public xorriso
(package
(name "xorriso")
(version "1.3.2")
(version "1.3.4")
(source (origin
(method url-fetch)
(uri (string-append "mirror://gnu/xorriso/xorriso-"
version ".tar.gz"))
(sha256
(base32
"1z04580nkkziy2flbxjjx0q6vp9p7vcp7yp0agx2aqz3l1vjcwhf"))))
"0wvxbvkpdydcbmqi9xz7nv8cna6vp9726ahmmxxyx56cz4xifr4x"))))
(build-system gnu-build-system)
(inputs
`(("acl" ,acl)

95
gnu/packages/games.scm Normal file
View File

@ -0,0 +1,95 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013 John Darrington <jmd@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu packages games)
#:use-module (guix licenses)
#:use-module (guix packages)
#:use-module (guix download)
#:use-module (gnu packages gettext)
#:use-module (gnu packages gl)
#:use-module (gnu packages glib)
#:use-module (gnu packages gnome)
#:use-module (gnu packages gtk)
#:use-module (gnu packages guile)
#:use-module (gnu packages libcanberra)
#:use-module (gnu packages python)
#:use-module (gnu packages readline)
#:use-module (gnu packages xorg)
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages sqlite)
#:use-module (guix build-system gnu))
(define-public gnubg
(package
(name "gnubg")
(version "1.02")
(source
(origin
(method url-fetch)
(uri (string-append "http://files.gnubg.org/media/sources/gnubg-release-"
version ".000-sources." "tar.gz"))
(sha256
(base32
"015mvjk2iw1cg1kxwxfnvp2rxb9cylf6yc39i30fdy414k07zkky"))))
(build-system gnu-build-system)
(inputs `(("glib" ,glib)
("readline" ,readline)
("gtk+" ,gtk+-2)
("mesa" ,mesa)
("gtkglext" ,gtkglext)
("sqlite" ,sqlite)
("libcanberra" ,libcanberra)))
(native-inputs `(("python-2" ,python-2)
("pkg-config" ,pkg-config)))
(home-page "https://gnubg.org")
(synopsis "Backgammon game")
(description "The GNU backgammon application can be used for playing, analyzing and
teaching the game. It has an advanced evaluation engine based on artificial
neural networks suitable for both beginners and advanced players. In
addition to a command-line interface, it also features an attractive, 3D
representation of the playing board.")
(license gpl3+)))
(define-public gnubik
(package
(name "gnubik")
(version "2.4.1")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://gnu/gnubik/gnubik-"
version ".tar.gz"))
(sha256
(base32
"0mfpwz341i1qpzi2qgslpc5i7d4fv7i01kv392m11pczqdc7i7m5"))))
(build-system gnu-build-system)
(inputs `(("gtk+" ,gtk+-2)
("mesa" ,mesa)
("libx11" ,libx11)
("guile" ,guile-2.0)
("gtkglext" ,gtkglext)))
(native-inputs `(("gettext" ,gnu-gettext)
("pkg-config" ,pkg-config)))
(home-page "https://www.gnu.org/software/gnubik/")
(synopsis "3d Rubik's cube game.")
(description "GNUbik is a puzzle game in which you must manipulate a cube to make
each of its faces have a uniform color. The game is customizable, allowing
you to set the size of the cube (the default is 3x3) or to change the colors.
You may even apply photos to the faces instead of colors. The game is
scriptable with Guile.")
(license gpl3+)))

4
gnu/packages/gdbm.scm
View File

@ -25,7 +25,7 @@
(define-public gdbm
(package
(name "gdbm")
(version "1.10")
(version "1.11")
(source
(origin
(method url-fetch)
@ -33,7 +33,7 @@
version ".tar.gz"))
(sha256
(base32
"0h9lfzdjc2yl849y0byg51h6xfjg0y7vg9jnsw3gpfwlbd617y13"))))
"1hz3jgh3pd4qzp6jy0l8pd8x01g9abw7csnrlnj1a2sxy122z4cd"))))
(arguments `(#:configure-flags '("--enable-libgdbm-compat")))
(build-system gnu-build-system)
(home-page "http://www.gnu.org/software/gdbm/")

59
gnu/packages/gl.scm
View File

@ -23,7 +23,12 @@
#:use-module (guix download)
#:use-module (guix build-system gnu)
#:use-module (guix packages)
#:use-module (gnu packages bison)
#:use-module (gnu packages flex)
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages python)
#:use-module (gnu packages xorg)
#:use-module (gnu packages xml)
#:use-module (gnu packages fontutils))
(define-public glu
@ -110,3 +115,57 @@ the X-Consortium license.")
rendering modes are: Bitmaps, Anti-aliased pixmaps, Texture maps, Outlines,
Polygon meshes, and Extruded polygon meshes")
(license l:x11)))
(define-public mesa
(package
(name "mesa")
;; In newer versions (9.0.5, 9.1 and 9.2 tested), "make" results in an
;; infinite configure loop, see
;; https://bugs.freedesktop.org/show_bug.cgi?id=58812
(version "8.0.5")
(source
(origin
(method url-fetch)
(uri (string-append
"ftp://ftp.freedesktop.org/pub/mesa/older-versions/8.x/"
version
"/MesaLib-" version
".tar.bz2"))
(sha256
(base32
"0pjs8x51c0i6mawgd4w03lxpyx5fnx7rc8plr8jfsscf9yiqs6si"))))
(build-system gnu-build-system)
(propagated-inputs
`(("glproto" ,glproto)
("libdrm" ,libdrm-2.4.33)
("libxdamage" ,libxdamage)
("libxxf86vm" ,libxxf86vm)))
(inputs
`(("dri2proto" ,dri2proto)
("expat" ,expat)
("libx11" ,libx11)
("libxfixes" ,libxfixes)
("libxml2" ,libxml2)
("makedepend" ,makedepend)))
(native-inputs
`(("pkg-config" ,pkg-config)
("flex" ,flex)
("bison" ,bison)
("python" ,python-2))) ; incompatible with Python 3 (print syntax)
(arguments
`(#:configure-flags
`("--with-gallium-drivers=r600,svga,swrast") ; drop r300 from the default list as it requires llvm
#:phases
(alist-cons-after
'unpack 'remove-symlink
(lambda* (#:key #:allow-other-keys)
;; remove dangling symlink to /usr/include/wine/windows
(delete-file "src/gallium/state_trackers/d3d1x/w32api"))
%standard-phases)))
(home-page "http://mesa3d.org/")
(synopsis "Mesa, an OpenGL implementation")
(description "Mesa is a free implementation of the OpenGL specification -
a system for rendering interactive 3D graphics. A variety of device drivers
allows Mesa to be used in many different environments ranging from software
emulation to complete hardware acceleration for modern GPUs.")
(license l:x11)))

28
gnu/packages/gnome.scm
View File

@ -21,6 +21,7 @@
#:use-module (guix packages)
#:use-module (guix download)
#:use-module (guix build-system gnu)
#:use-module (gnu packages)
#:use-module (gnu packages glib)
#:use-module (gnu packages gnupg)
#:use-module (gnu packages gstreamer)
@ -34,6 +35,7 @@
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages python)
#:use-module (gnu packages xml)
#:use-module (gnu packages gl)
#:use-module (gnu packages xorg))
(define-public brasero
@ -468,3 +470,29 @@ demand (lazy) programming language support for C, Python and JS; simplicity of
the API")
(license lgpl2.0+)))
(define-public gtkglext
(package
(name "gtkglext")
(version "1.2.0")
(source (origin
(method url-fetch)
(uri (string-append "mirror://sourceforge/project/gtkglext/gtkglext/"
version "/gtkglext-" version ".tar.gz"))
(sha256
(base32 "1ya4d2j2aacr9ii5zj4ac95fjpdvlm2rg79mgnk7yvl1dcy3y1z5"))
(patches (list
(search-patch "gtkglext-remove-pangox-dependency.patch")
(search-patch "gtkglext-disable-disable-deprecated.patch")))))
(build-system gnu-build-system)
(inputs `(("gtk+" ,gtk+-2)
("mesa" ,mesa)
("libx11" ,libx11)
("libxt" ,libxt)))
(native-inputs `(("pkg-config" ,pkg-config)))
(home-page "https://projects.gnome.org/gtkglext")
(synopsis "OpenGL extension to GTK+.")
(description "GtkGLExt is an OpenGL extension to GTK+. It provides
additional GDK objects which support OpenGL rendering in GTK+ and GtkWidget
API add-ons to make GTK+ widgets OpenGL-capable.")
(license lgpl2.1+)))

4
gnu/packages/gnunet.scm
View File

@ -41,14 +41,14 @@
(define-public libextractor
(package
(name "libextractor")
(version "1.2")
(version "1.3")
(source (origin
(method url-fetch)
(uri (string-append "mirror://gnu/libextractor/libextractor-"
version ".tar.gz"))
(sha256
(base32
"1n7z6s5ils6xmf6b0z1xda41maxj94c1n6wlyyxmacs5lrkh2a96"))))
"0zvv7wd011npcx7yphw9bpgivyxz6mlp87a57n96nv85k96dd2l6"))))
(build-system gnu-build-system)
;; WARNING: Checks require /dev/shm to be in the build chroot, especially
;; not to be a symbolic link to /run/shm.

13
gnu/packages/gnupg.scm
View File

@ -78,6 +78,7 @@ Daemon and possibly more in the future.")
`(#:configure-flags
(list (string-append "--with-gpg-error-prefix="
(assoc-ref %build-inputs "libgpg-error")))))
(outputs '("out" "debug"))
(home-page "http://gnupg.org/")
(synopsis "Cryptographic function library")
(description
@ -87,6 +88,18 @@ algorithms, public key algorithms, large integer functions and random number
generation.")
(license lgpl2.0+)))
(define-public libgcrypt-1.5
(package (inherit libgcrypt)
(version "1.5.3")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://gnupg/libgcrypt/libgcrypt-"
version ".tar.bz2"))
(sha256
(base32
"1lar8y3lh61zl5flljpz540d78g99h4d5idfwrfw8lm3gm737xdw"))))))
(define-public libassuan
(package
(name "libassuan")

1
gnu/packages/gnuzilla.scm
View File

@ -37,6 +37,7 @@
#:use-module (gnu packages libffi)
#:use-module (gnu packages python)
#:use-module (gnu packages xorg)
#:use-module (gnu packages gl)
#:use-module (gnu packages yasm)
#:use-module (gnu packages zip))

4
gnu/packages/iso-codes.scm
View File

@ -28,7 +28,7 @@
(define-public iso-codes
(package
(name "iso-codes")
(version "3.47")
(version "3.49")
(source (origin
(method url-fetch)
(uri (string-append
@ -36,7 +36,7 @@
version ".tar.xz"))
(sha256
(base32
"1ka2rrnfwbydklpx9p1cw74z03v5h0df3pjplq5ic689jngcv6a8"))))
"1ryk5i467p7xxrbrqynb35ci046yj9k9b4d3hfxzass962lz9q04"))))
(build-system gnu-build-system)
(inputs
`(("gettext" ,gnu-gettext)

72
gnu/packages/lsh.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@ -30,7 +30,7 @@
#:use-module (gnu packages multiprecision)
#:use-module (gnu packages readline)
#:use-module (gnu packages gperf)
#:use-module (gnu packages base))
#:use-module (gnu packages guile))
(define-public liboop
(package
@ -61,27 +61,45 @@ basis for almost any application.")
(package
(name "lsh")
(version "2.1")
(source
(origin
(source (origin
(method url-fetch)
(uri (string-append "mirror://gnu/lsh/lsh-"
version ".tar.gz"))
(sha256
(base32
"1qqjy9zfzgny0rkb27c8c7dfsylvb6n0ld8h3an2r83pmaqr9gwb"))))
"1qqjy9zfzgny0rkb27c8c7dfsylvb6n0ld8h3an2r83pmaqr9gwb"))
(modules '((guix build utils)))
(snippet
'(begin
(use-modules (guix build utils))
(substitute* "src/testsuite/functions.sh"
(("localhost")
;; Avoid host name lookups since they don't work in
;; chroot builds.
"127.0.0.1")
(("set -e")
;; Make tests more verbose.
"set -e\nset -x"))
(substitute* (find-files "src/testsuite" "-test$")
(("localhost") "127.0.0.1"))
(substitute* "src/testsuite/login-auth-test"
(("/bin/cat") "cat"))))))
(build-system gnu-build-system)
(native-inputs
`(("m4" ,m4)
("guile" ,guile-2.0)
("gperf" ,gperf)
("psmisc" ,psmisc))) ; for `killall'
(inputs
`(("nettle" ,nettle)
("linux-pam" ,linux-pam)
("m4" ,m4)
("readline" ,readline)
("liboop" ,liboop)
("zlib" ,guix:zlib)
("gmp" ,gmp)
("guile" ,guile-final)
("gperf" ,gperf)
("psmisc" ,psmisc) ; for `killall'
))
("gmp" ,gmp)))
(arguments
'(;; Skip the `configure' test that checks whether /dev/ptmx &
;; co. work as expected, because it relies on impurities (for
@ -95,27 +113,19 @@ basis for almost any application.")
#:phases
(alist-cons-before
'configure 'fix-test-suite
(lambda _
'configure 'pre-configure
(lambda* (#:key inputs #:allow-other-keys)
;; Make sure 'lsh' and 'lshd' pick 'sexp-conv' in the right place by
;; default.
(substitute* "src/environ.h.in"
(("^#define PATH_SEXP_CONV.*")
(let* ((nettle (assoc-ref inputs "nettle"))
(sexp-conv (string-append nettle "/bin/sexp-conv")))
(string-append "#define PATH_SEXP_CONV \""
sexp-conv "\"\n"))))
;; Tests rely on $USER being set.
(setenv "USER" "guix")
(substitute* "src/testsuite/functions.sh"
(("localhost")
;; Avoid host name lookups since they don't work in chroot
;; builds.
"127.0.0.1")
(("set -e")
;; Make tests more verbose.
"set -e\nset -x"))
(substitute* (find-files "src/testsuite" "-test$")
(("localhost") "127.0.0.1"))
(substitute* "src/testsuite/login-auth-test"
(("/bin/cat")
;; Use the right path to `cat'.
(which "cat"))))
(setenv "USER" "guix"))
%standard-phases)))
(home-page "http://www.lysator.liu.se/~nisse/lsh/")
(synopsis "GNU implementation of the Secure Shell (ssh) protocols")

10
gnu/packages/nettle.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@ -36,7 +36,13 @@
(base32
"0h2vap31yvi1a438d36lg1r1nllfx3y19r4rfxv7slrm6kafnwdw"))))
(build-system gnu-build-system)
(inputs `(("m4" ,m4)))
(arguments
;; 'sexp-conv' and other programs need to have their RUNPATH point to
;; $libdir, which is not the case by default. Work around it.
'(#:configure-flags (list (string-append "LDFLAGS=-Wl,-rpath="
(assoc-ref %outputs "out")
"/lib"))))
(native-inputs `(("m4" ,m4)))
(propagated-inputs `(("gmp" ,gmp)))
(home-page "http://www.lysator.liu.se/~nisse/nettle/")
(synopsis "C library for low-level cryptographic functionality")

4
gnu/packages/parallel.scm
View File

@ -27,7 +27,7 @@
(define-public parallel
(package
(name "parallel")
(version "20131122")
(version "20131222")
(source
(origin
(method url-fetch)
@ -35,7 +35,7 @@
version ".tar.bz2"))
(sha256
(base32
"1l19grs8nimkninig4h0hfmnykm41j0amcvav6ic4wfd33v0lppg"))))
"08ggxb4id263623mr14clafsdl1n1zhfx13z3mn6kqbd4d6vwwk7"))))
(build-system gnu-build-system)
(inputs `(("perl" ,perl)))
(home-page "http://www.gnu.org/software/parallel/")

36
gnu/packages/patches/gtkglext-disable-disable-deprecated.patch Normal file
View File

@ -0,0 +1,36 @@
Having DISABLE_DEPRECATED flags set in the distribution breaks
building with libraries later than those which the maintainer
happened to have installed. This patch removes them.
diff -r -U 3 a/gtk/Makefile.am b/gtk/Makefile.am
--- a/gtk/Makefile.am 2003-05-09 15:55:05.000000000 +0200
+++ b/gtk/Makefile.am 2013-12-26 15:06:38.000000000 +0100
@@ -36,11 +36,7 @@
-I$(top_srcdir) \
-I$(top_builddir)/gdk \
$(GTKGLEXT_DEBUG_FLAGS) \
- $(GTKGLEXT_DEP_CFLAGS) \
- -DG_DISABLE_DEPRECATED \
- -DGDK_DISABLE_DEPRECATED \
- -DGDK_PIXBUF_DISABLE_DEPRECATED \
- -DGTK_DISABLE_DEPRECATED
+ $(GTKGLEXT_DEP_CFLAGS)
common_ldflags = \
-version-info $(LT_CURRENT):$(LT_REVISION):$(LT_AGE) \
diff -r -U 3 a/gtk/Makefile.in b/gtk/Makefile.in
--- a/gtk/Makefile.in 2006-02-05 04:17:42.000000000 +0100
+++ b/gtk/Makefile.in 2013-12-26 15:07:00.000000000 +0100
@@ -234,11 +234,7 @@
-I$(top_srcdir) \
-I$(top_builddir)/gdk \
$(GTKGLEXT_DEBUG_FLAGS) \
- $(GTKGLEXT_DEP_CFLAGS) \
- -DG_DISABLE_DEPRECATED \
- -DGDK_DISABLE_DEPRECATED \
- -DGDK_PIXBUF_DISABLE_DEPRECATED \
- -DGTK_DISABLE_DEPRECATED
+ $(GTKGLEXT_DEP_CFLAGS)
common_ldflags = \

132
gnu/packages/patches/gtkglext-remove-pangox-dependency.patch Normal file
View File

@ -0,0 +1,132 @@
This patch removes the dependency on pangox which has been deprecated. It
achieves the same result as the upstream patch at
https://git.gnome.org/browse/gtkglext/commit/?id=df7a7b35b80b395d7ba411c7f727970a46fb0588
Like the upstream patch, it removes the functions gdk_gl_font_use_pango_font,
and gdk_gl_font_use_pango_font_for_display from the API.
diff -r -U 3 a/configure b/configure
--- a/configure 2006-02-05 04:17:47.000000000 +0100
+++ b/configure 2013-12-26 12:55:21.000000000 +0100
@@ -19880,14 +19880,12 @@
gtk+-2.0 >= 2.0.0 \\
gdk-2.0 >= 2.0.0 \\
pango >= 1.0.0 \\
-pangox >= 1.0.0 \\
gmodule-2.0 >= 2.0.0 \\
\"") >&5
($PKG_CONFIG --exists --print-errors "\
gtk+-2.0 >= 2.0.0 \
gdk-2.0 >= 2.0.0 \
pango >= 1.0.0 \
-pangox >= 1.0.0 \
gmodule-2.0 >= 2.0.0 \
") 2>&5
ac_status=$?
@@ -19897,7 +19895,6 @@
gtk+-2.0 >= 2.0.0 \
gdk-2.0 >= 2.0.0 \
pango >= 1.0.0 \
-pangox >= 1.0.0 \
gmodule-2.0 >= 2.0.0 \
" 2>/dev/null`
else
@@ -19916,14 +19913,12 @@
gtk+-2.0 >= 2.0.0 \\
gdk-2.0 >= 2.0.0 \\
pango >= 1.0.0 \\
-pangox >= 1.0.0 \\
gmodule-2.0 >= 2.0.0 \\
\"") >&5
($PKG_CONFIG --exists --print-errors "\
gtk+-2.0 >= 2.0.0 \
gdk-2.0 >= 2.0.0 \
pango >= 1.0.0 \
-pangox >= 1.0.0 \
gmodule-2.0 >= 2.0.0 \
") 2>&5
ac_status=$?
@@ -19933,7 +19928,6 @@
gtk+-2.0 >= 2.0.0 \
gdk-2.0 >= 2.0.0 \
pango >= 1.0.0 \
-pangox >= 1.0.0 \
gmodule-2.0 >= 2.0.0 \
" 2>/dev/null`
else
@@ -19958,7 +19952,6 @@
gtk+-2.0 >= 2.0.0 \
gdk-2.0 >= 2.0.0 \
pango >= 1.0.0 \
-pangox >= 1.0.0 \
gmodule-2.0 >= 2.0.0 \
"`
else
@@ -19966,7 +19959,6 @@
gtk+-2.0 >= 2.0.0 \
gdk-2.0 >= 2.0.0 \
pango >= 1.0.0 \
-pangox >= 1.0.0 \
gmodule-2.0 >= 2.0.0 \
"`
fi
@@ -19977,7 +19969,6 @@
gtk+-2.0 >= 2.0.0 \
gdk-2.0 >= 2.0.0 \
pango >= 1.0.0 \
-pangox >= 1.0.0 \
gmodule-2.0 >= 2.0.0 \
) were not met:
@@ -19994,7 +19985,6 @@
gtk+-2.0 >= 2.0.0 \
gdk-2.0 >= 2.0.0 \
pango >= 1.0.0 \
-pangox >= 1.0.0 \
gmodule-2.0 >= 2.0.0 \
) were not met:
@@ -25420,7 +25410,7 @@
# CFLAGS and LIBS
##################################################
-GDKGLEXT_PACKAGES="gdk-2.0 pango pangox gmodule-2.0"
+GDKGLEXT_PACKAGES="gdk-2.0 pango gmodule-2.0"
GDKGLEXT_EXTRA_CFLAGS="$GL_CFLAGS $GDKGLEXT_WIN_CFLAGS"
GDKGLEXT_EXTRA_LIBS="$GL_LIBS $GDKGLEXT_WIN_LIBS"
GDKGLEXT_DEP_CFLAGS="$GDKGLEXT_EXTRA_CFLAGS `$PKG_CONFIG --cflags $GDKGLEXT_PACKAGES`"
diff -r -U 3 a/gdk/x11/Makefile.in b/gdk/x11/Makefile.in
--- a/gdk/x11/Makefile.in 2006-02-05 04:17:42.000000000 +0100
+++ b/gdk/x11/Makefile.in 2013-12-26 13:12:04.000000000 +0100
@@ -257,7 +257,6 @@
gdkgldrawable-x11.c \
gdkglpixmap-x11.c \
gdkglwindow-x11.c \
- gdkglfont-x11.c \
gdkglglxext.c
@@ -288,7 +287,7 @@
am__objects_1 =
am__objects_2 = gdkglquery-x11.lo gdkglconfig-x11.lo gdkgloverlay-x11.lo \
gdkglcontext-x11.lo gdkgldrawable-x11.lo gdkglpixmap-x11.lo \
- gdkglwindow-x11.lo gdkglfont-x11.lo gdkglglxext.lo
+ gdkglwindow-x11.lo gdkglglxext.lo
am__objects_3 = $(am__objects_1) $(am__objects_2)
am_libgdkglext_x11_la_OBJECTS = $(am__objects_3)
libgdkglext_x11_la_OBJECTS = $(am_libgdkglext_x11_la_OBJECTS)
@@ -299,7 +298,6 @@
@AMDEP_TRUE@DEP_FILES = ./$(DEPDIR)/gdkglconfig-x11.Plo \
@AMDEP_TRUE@ ./$(DEPDIR)/gdkglcontext-x11.Plo \
@AMDEP_TRUE@ ./$(DEPDIR)/gdkgldrawable-x11.Plo \
-@AMDEP_TRUE@ ./$(DEPDIR)/gdkglfont-x11.Plo \
@AMDEP_TRUE@ ./$(DEPDIR)/gdkglglxext.Plo \
@AMDEP_TRUE@ ./$(DEPDIR)/gdkgloverlay-x11.Plo \
@AMDEP_TRUE@ ./$(DEPDIR)/gdkglpixmap-x11.Plo \
@@ -349,7 +347,6 @@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/gdkglconfig-x11.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/gdkglcontext-x11.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/gdkgldrawable-x11.Plo@am__quote@
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/gdkglfont-x11.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/gdkglglxext.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/gdkgloverlay-x11.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/gdkglpixmap-x11.Plo@am__quote@

29
gnu/packages/patches/pulseaudio-volume-test.patch Normal file
View File

@ -0,0 +1,29 @@
Fix seemingly random failures of 'volume-test' in particular on 32-bit
machines. See <https://bugs.freedesktop.org/show_bug.cgi?id=72374> for
details.
From 27e47c72a25846e107b6e450c3a1480a2742382e Mon Sep 17 00:00:00 2001
From: Tanu Kaskinen <tanu.kaskinen@linux.intel.com>
Date: Sat, 14 Dec 2013 07:21:22 +0000
Subject: volume-test: Increase the allowed number of rouding errors
BugLink: https://bugs.freedesktop.org/show_bug.cgi?id=72374
---
diff --git a/src/tests/volume-test.c b/src/tests/volume-test.c
index a2daf3e..1ab0b5c 100644
--- a/src/tests/volume-test.c
+++ b/src/tests/volume-test.c
@@ -138,7 +138,13 @@ START_TEST (volume_test) {
pa_log("max deviation: %lu n=%lu", (unsigned long) md, (unsigned long) mdn);
fail_unless(md <= 1);
- fail_unless(mdn <= 251);
+
+ /* mdn counts the times there were rounding errors during the test. The
+ * number of rounding errors seems to vary slightly depending on the
+ * hardware. The original limit was 251 errors, but it was increased to 253
+ * when the test was failing on Tanu's laptop.
+ * See https://bugs.freedesktop.org/show_bug.cgi?id=72374 */
+ fail_unless(mdn <= 253);
}
END_TEST

15
gnu/packages/pulseaudio.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@ -143,7 +143,9 @@ parse JSON formatted strings back into the C representation of JSON objects.")
(sha256
(base32
"1bndz4l8jxyq3zq128gzp3gryxl6yjs66j2y1d7yabw2n5mv7kim"))
(patches (list (search-patch "pulseaudio-test-timeouts.patch")))))
(patches (map search-patch
'("pulseaudio-test-timeouts.patch"
"pulseaudio-volume-test.patch")))))
(build-system gnu-build-system)
(arguments
`(#:configure-flags '("--localstatedir=/var" ;"--sysconfdir=/etc"
@ -154,14 +156,7 @@ parse JSON formatted strings back into the C representation of JSON objects.")
;; 'tests/lock-autospawn-test.c' wants to create a file
;; under ~/.config/pulse.
(setenv "HOME" (getcwd)))
%standard-phases)
,@(if (or (string=? (%current-system) "i686-linux")
(string=? (%current-system) "mips64el-linux"))
;; Work around test failure:
;; <https://bugs.freedesktop.org/show_bug.cgi?id=72374>.
'(#:tests? #f)
'())))
%standard-phases)))
(inputs
;; TODO: Add optional inputs (GTK+?).
`(;; ("sbc" ,sbc)

8
gnu/packages/python.scm
View File

@ -41,7 +41,7 @@
(define-public python-2
(package
(name "python")
(version "2.7.5")
(version "2.7.6")
(source
(origin
(method url-fetch)
@ -49,7 +49,7 @@
version "/Python-" version ".tar.xz"))
(sha256
(base32
"1c8xan2dlsqfq8q82r3mhl72v3knq3qyn71fjq89xikx2smlqg7k"))))
"18gnpyh071dxa0rv3silrz92jw9qpblswzwv4gzqcwxzz20qxmhz"))))
(build-system gnu-build-system)
(arguments
`(#:tests? #f
@ -160,7 +160,7 @@ data types.")
(define-public python
(package (inherit python-2)
(version "3.3.2")
(version "3.3.3")
(source
(origin
(method url-fetch)
@ -168,7 +168,7 @@ data types.")
version "/Python-" version ".tar.xz"))
(sha256
(base32
"0hsbwqjnhr85a2w252c8d3yj8d9i5sy8s6a6cfk6zqqhp3234nvl"))))
"11f6hg9wdhm6hyzj49gxlvvp1s0l5hqgcsq1i4ayygqs1arpb4ik"))))
(native-search-paths
(list (search-path-specification
(variable "PYTHONPATH")

1
gnu/packages/qemu.scm
View File

@ -36,6 +36,7 @@
#:use-module (gnu packages linux)
#:use-module (gnu packages samba)
#:use-module (gnu packages xorg)
#:use-module (gnu packages gl)
#:use-module (gnu packages sdl)
#:use-module (gnu packages perl))

1
gnu/packages/qt.scm
View File

@ -37,6 +37,7 @@
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages pulseaudio)
#:use-module (gnu packages python)
#:use-module (gnu packages gl)
#:use-module (gnu packages xorg))
(define-public libxkbcommon

1
gnu/packages/sdl.scm
View File

@ -31,6 +31,7 @@
#:use-module (gnu packages oggvorbis)
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages pulseaudio)
#:use-module (gnu packages gl)
#:use-module (gnu packages xorg)
#:export (sdl
sdl2

10
gnu/packages/shishi.scm
View File

@ -43,7 +43,15 @@
(inputs
`(("gnutls" ,gnutls)
("zlib" ,zlib)
("libgcrypt" ,libgcrypt)
;; libgcrypt 1.6 fails because of the following test:
;; #include <gcrypt.h>
;; /* GCRY_MODULE_ID_USER was added in 1.4.4 and gc-libgcrypt.c
;; will fail on startup if we don't have 1.4.4 or later, so
;; test for it early. */
;; #if !defined GCRY_MODULE_ID_USER
;; error too old libgcrypt
;; #endif
("libgcrypt" ,libgcrypt-1.5)
("libtasn1" ,libtasn1)))
(home-page "http://www.gnu.org/software/shishi/")
(synopsis "Implementation of the Kerberos 5 network security system")

11
gnu/packages/ssh.scm
View File

@ -36,14 +36,14 @@
(define-public libssh
(package
(name "libssh")
(version "0.5.3")
(version "0.5.5")
(source (origin
(method url-fetch)
(uri (string-append "http://www.libssh.org/files/0.5/libssh-"
(uri (string-append "https://red.libssh.org/attachments/download/51/libssh-"
version ".tar.gz"))
(sha256
(base32
"1w6s217vjq0w3v5i0c5ql6m0ki1yz05g9snah3azxfkl9k4schpd"))))
"17cfdff4hc0ijzrr15biq29fiabafz0bw621zlkbwbc1zh2hzpy0"))))
(build-system cmake-build-system)
(arguments
'(#:configure-flags '("-DWITH_GCRYPT=ON"
@ -80,7 +80,10 @@
lib))))
%standard-phases)))
(inputs `(("zlib" ,zlib)
("libgcrypt" ,libgcrypt)))
;; Link against an older gcrypt, because libssh tries to access
;; fields of 'gcry_thread_cbs' that are now private:
;; src/threads.c:72:26: error: 'struct gcry_thread_cbs' has no member named 'mutex_init'
("libgcrypt", libgcrypt-1.5)))
(native-inputs `(("patchelf" ,patchelf)))
(synopsis "SSH client library")
(description

4
gnu/packages/vim.scm
View File

@ -31,14 +31,14 @@
(define-public vim
(package
(name "vim")
(version "7.3")
(version "7.4")
(source (origin
(method url-fetch)
(uri (string-append "ftp://ftp.vim.org/pub/vim/unix/vim-"
version ".tar.bz2"))
(sha256
(base32
"079201qk8g9yisrrb0dn52ch96z3lzw6z473dydw9fzi0xp5spaw"))))
"1pjaffap91l2rb9pjnlbrpvb3ay5yhhr3g91zabjvw1rqk9adxfh"))))
(build-system gnu-build-system)
(arguments
`(#:test-target "test"

62
gnu/packages/xorg.scm
View File

@ -28,6 +28,7 @@
#:use-module (gnu packages flex)
#:use-module (gnu packages fontutils)
#:use-module (gnu packages gettext)
#:use-module (gnu packages gl)
#:use-module (gnu packages glib)
#:use-module (gnu packages gnupg)
#:use-module (gnu packages gperf)
@ -2969,7 +2970,8 @@ tracking.")
"0isiwx516gww8hfk3vy7js83yziyjym9mq2zjadyq1a8v5gqf9y8"))))
(build-system gnu-build-system)
(inputs `(("libx11" ,libx11)
("libxext" ,libxext)))
("libxext" ,libxext)
("xorg-server" ,xorg-server)))
(native-inputs
`(("pkg-config" ,pkg-config)))
(home-page "http://www.x.org/wiki/")
@ -4266,64 +4268,6 @@ tracking.")
(license license:x11)))
;; package outside the x.org system proper of height 3
(define-public mesa
(package
(name "mesa")
;; In newer versions (9.0.5, 9.1 and 9.2 tested), "make" results in an
;; infinite configure loop, see
;; https://bugs.freedesktop.org/show_bug.cgi?id=58812
(version "8.0.5")
(source
(origin
(method url-fetch)
(uri (string-append
"ftp://ftp.freedesktop.org/pub/mesa/older-versions/8.x/"
version
"/MesaLib-" version
".tar.bz2"))
(sha256
(base32
"0pjs8x51c0i6mawgd4w03lxpyx5fnx7rc8plr8jfsscf9yiqs6si"))))
(build-system gnu-build-system)
(propagated-inputs
`(("glproto" ,glproto)
("libdrm" ,libdrm-2.4.33)
("libxdamage" ,libxdamage)
("libxxf86vm" ,libxxf86vm)))
(inputs
`(("dri2proto" ,dri2proto)
("expat" ,expat)
("libx11" ,libx11)
("libxfixes" ,libxfixes)
("libxml2" ,libxml2)
("makedepend" ,makedepend)))
(native-inputs
`(("pkg-config" ,pkg-config)
("flex" ,flex)
("bison" ,bison)
("python" ,python-2))) ; incompatible with Python 3 (print syntax)
(arguments
`(#:configure-flags
`("--with-gallium-drivers=r600,svga,swrast") ; drop r300 from the default list as it requires llvm
#:phases
(alist-cons-after
'unpack 'remove-symlink
(lambda* (#:key #:allow-other-keys)
;; remove dangling symlink to /usr/include/wine/windows
(delete-file "src/gallium/state_trackers/d3d1x/w32api"))
%standard-phases)))
(home-page "http://mesa3d.org/")
(synopsis "Mesa, an OpenGL implementation")
(description "Mesa is a free implementation of the OpenGL specification -
a system for rendering interactive 3D graphics. A variety of device drivers
allows Mesa to be used in many different environments ranging from software
emulation to complete hardware acceleration for modern GPUs.")
(license license:x11)))
;; packages of height 3 in the propagated-inputs tree
(define-public libxcb

12
guix/config.scm.in
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@ -23,6 +23,7 @@
%guix-home-page-url
%store-directory
%state-directory
%config-directory
%system
%libgcrypt
%nixpkgs
@ -50,11 +51,16 @@
"@PACKAGE_URL@")
(define %store-directory
"@storedir@")
(or (and=> (getenv "NIX_STORE_DIR") canonicalize-path)
"@storedir@"))
(define %state-directory
;; This must match `NIX_STATE_DIR' as defined in `daemon.am'.
"@guix_localstatedir@/nix")
(or (getenv "NIX_STATE_DIR") "@guix_localstatedir@/nix"))
(define %config-directory
;; This must match `NIX_CONF_DIR' as defined in `daemon.am'.
(or (getenv "NIX_CONF_DIR") "@guix_sysconfdir@/guix"))
(define %system
"@guix_system@")

372
guix/pk-crypto.scm Normal file
View File

@ -0,0 +1,372 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix pk-crypto)
#:use-module (guix config)
#:use-module ((guix utils)
#:select (bytevector->base16-string
base16-string->bytevector))
#:use-module (system foreign)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 match)
#:export (canonical-sexp?
error-source
error-string
string->canonical-sexp
canonical-sexp->string
number->canonical-sexp
canonical-sexp-car
canonical-sexp-cdr
canonical-sexp-nth
canonical-sexp-nth-data
canonical-sexp-length
canonical-sexp-null?
canonical-sexp-list?
bytevector->hash-data
hash-data->bytevector
sign
verify
generate-key
find-sexp-token
canonical-sexp->sexp
sexp->canonical-sexp))
;;; Commentary:
;;;
;;; Public key cryptographic routines from GNU Libgcrypt.
;;;;
;;; Libgcrypt uses "canonical s-expressions" to represent key material,
;;; parameters, and data. We keep it as an opaque object to map them to
;;; Scheme s-expressions because (1) Libgcrypt sexps may be stored in secure
;;; memory, and (2) the read syntax is different.
;;;
;;; A 'canonical-sexp->sexp' procedure is provided nevertheless, for use in
;;; cases where it is safe to move data out of Libgcrypt---e.g., when
;;; processing ACL entries, public keys, etc.
;;;
;;; Canonical sexps were defined by Rivest et al. in the IETF draft at
;;; <http://people.csail.mit.edu/rivest/Sexp.txt> for the purposes of SPKI
;;; (see <http://www.ietf.org/rfc/rfc2693.txt>.)
;;;
;;; Code:
;; Libgcrypt "s-expressions".
(define-wrapped-pointer-type <canonical-sexp>
canonical-sexp?
naked-pointer->canonical-sexp
canonical-sexp->pointer
(lambda (obj port)
;; Don't print OBJ's external representation: we don't want key material
;; to leak in backtraces and such.
(format port "#<canonical-sexp ~a | ~a>"
(number->string (object-address obj) 16)
(number->string (pointer-address (canonical-sexp->pointer obj))
16))))
(define libgcrypt-func
(let ((lib (dynamic-link %libgcrypt)))
(lambda (func)
"Return a pointer to symbol FUNC in libgcrypt."
(dynamic-func func lib))))
(define finalize-canonical-sexp!
(libgcrypt-func "gcry_sexp_release"))
(define-inlinable (pointer->canonical-sexp ptr)
"Return a <canonical-sexp> that wraps PTR."
(let* ((sexp (naked-pointer->canonical-sexp ptr))
(ptr* (canonical-sexp->pointer sexp)))
;; Did we already have a <canonical-sexp> object for PTR?
(when (equal? ptr ptr*)
;; No, so we can safely add a finalizer (in Guile 2.0.9
;; 'set-pointer-finalizer!' *adds* a finalizer rather than replacing the
;; existing one.)
(set-pointer-finalizer! ptr finalize-canonical-sexp!))
sexp))
(define error-source
(let* ((ptr (libgcrypt-func "gcry_strsource"))
(proc (pointer->procedure '* ptr (list int))))
(lambda (err)
"Return the error source (a string) for ERR, an error code as thrown
along with 'gcry-error'."
(pointer->string (proc err)))))
(define error-string
(let* ((ptr (libgcrypt-func "gcry_strerror"))
(proc (pointer->procedure '* ptr (list int))))
(lambda (err)
"Return the error description (a string) for ERR, an error code as
thrown along with 'gcry-error'."
(pointer->string (proc err)))))
(define string->canonical-sexp
(let* ((ptr (libgcrypt-func "gcry_sexp_new"))
(proc (pointer->procedure int ptr `(* * ,size_t ,int))))
(lambda (str)
"Parse STR and return the corresponding gcrypt s-expression."
(let* ((sexp (bytevector->pointer (make-bytevector (sizeof '*))))
(err (proc sexp (string->pointer str) 0 1)))
(if (= 0 err)
(pointer->canonical-sexp (dereference-pointer sexp))
(throw 'gcry-error err))))))
(define-syntax GCRYSEXP_FMT_ADVANCED
(identifier-syntax 3))
(define canonical-sexp->string
(let* ((ptr (libgcrypt-func "gcry_sexp_sprint"))
(proc (pointer->procedure size_t ptr `(* ,int * ,size_t))))
(lambda (sexp)
"Return a textual representation of SEXP."
(let loop ((len 1024))
(let* ((buf (bytevector->pointer (make-bytevector len)))
(size (proc (canonical-sexp->pointer sexp)
GCRYSEXP_FMT_ADVANCED buf len)))
(if (zero? size)
(loop (* len 2))
(pointer->string buf size "ISO-8859-1")))))))
(define canonical-sexp-car
(let* ((ptr (libgcrypt-func "gcry_sexp_car"))
(proc (pointer->procedure '* ptr '(*))))
(lambda (lst)
"Return the first element of LST, an sexp, if that element is a list;
return #f if LST or its first element is not a list (this is different from
the usual Lisp 'car'.)"
(let ((result (proc (canonical-sexp->pointer lst))))
(if (null-pointer? result)
#f
(pointer->canonical-sexp result))))))
(define canonical-sexp-cdr
(let* ((ptr (libgcrypt-func "gcry_sexp_cdr"))
(proc (pointer->procedure '* ptr '(*))))
(lambda (lst)
"Return the tail of LST, an sexp, or #f if LST is not a list."
(let ((result (proc (canonical-sexp->pointer lst))))
(if (null-pointer? result)
#f
(pointer->canonical-sexp result))))))
(define canonical-sexp-nth
(let* ((ptr (libgcrypt-func "gcry_sexp_nth"))
(proc (pointer->procedure '* ptr `(* ,int))))
(lambda (lst index)
"Return the INDEXth nested element of LST, an s-expression. Return #f
if that element does not exist, or if it's an atom. (Note: this is obviously
different from Scheme's 'list-ref'.)"
(let ((result (proc (canonical-sexp->pointer lst) index)))
(if (null-pointer? result)
#f
(pointer->canonical-sexp result))))))
(define (dereference-size_t p)
"Return the size_t value pointed to by P."
(bytevector-uint-ref (pointer->bytevector p (sizeof size_t))
0 (native-endianness)
(sizeof size_t)))
(define canonical-sexp-length
(let* ((ptr (libgcrypt-func "gcry_sexp_length"))
(proc (pointer->procedure int ptr '(*))))
(lambda (sexp)
"Return the length of SEXP if it's a list (including the empty list);
return zero if SEXP is an atom."
(proc (canonical-sexp->pointer sexp)))))
(define token-string?
(let ((token-cs (char-set-union char-set:digit
char-set:letter
(char-set #\- #\. #\/ #\_
#\: #\* #\+ #\=))))
(lambda (str)
"Return #t if STR is a token as per Section 4.3 of
<http://people.csail.mit.edu/rivest/Sexp.txt>."
(and (not (string-null? str))
(string-every token-cs str)
(not (char-set-contains? char-set:digit (string-ref str 0)))))))
(define canonical-sexp-nth-data
(let* ((ptr (libgcrypt-func "gcry_sexp_nth_data"))
(proc (pointer->procedure '* ptr `(* ,int *))))
(lambda (lst index)
"Return as a symbol (for \"sexp tokens\") or a bytevector (for any other
\"octet string\") the INDEXth data element (atom) of LST, an s-expression.
Return #f if that element does not exist, or if it's a list."
(let* ((size* (bytevector->pointer (make-bytevector (sizeof '*))))
(result (proc (canonical-sexp->pointer lst) index size*)))
(if (null-pointer? result)
#f
(let* ((len (dereference-size_t size*))
(str (pointer->string result len "ISO-8859-1")))
;; The sexp spec speaks of "tokens" and "octet strings".
;; Sometimes these octet strings are actual strings (text),
;; sometimes they're bytevectors, and sometimes they're
;; multi-precision integers (MPIs). Only the application knows.
;; However, for convenience, we return a symbol when a token is
;; encountered since tokens are frequent (at least in the 'car'
;; of each sexp.)
(if (token-string? str)
(string->symbol str) ; an sexp "token"
(bytevector-copy ; application data, textual or binary
(pointer->bytevector result len)))))))))
(define (number->canonical-sexp number)
"Return an s-expression representing NUMBER."
(string->canonical-sexp (string-append "#" (number->string number 16) "#")))
(define* (bytevector->hash-data bv #:optional (hash-algo "sha256"))
"Given BV, a bytevector containing a hash, return an s-expression suitable
for use as the data for 'sign'."
(string->canonical-sexp
(format #f "(data (flags pkcs1) (hash \"~a\" #~a#))"
hash-algo
(bytevector->base16-string bv))))
(define (hash-data->bytevector data)
"Return two values: the hash value (a bytevector), and the hash algorithm (a
string) extracted from DATA, an sexp as returned by 'bytevector->hash-data'.
Return #f if DATA does not conform."
(let ((hash (find-sexp-token data 'hash)))
(if hash
(let ((algo (canonical-sexp-nth-data hash 1))
(value (canonical-sexp-nth-data hash 2)))
(values value (symbol->string algo)))
(values #f #f))))
(define sign
(let* ((ptr (libgcrypt-func "gcry_pk_sign"))
(proc (pointer->procedure int ptr '(* * *))))
(lambda (data secret-key)
"Sign DATA (an s-expression) with SECRET-KEY (an s-expression whose car
is 'private-key'.)"
(let* ((sig (bytevector->pointer (make-bytevector (sizeof '*))))
(err (proc sig (canonical-sexp->pointer data)
(canonical-sexp->pointer secret-key))))
(if (= 0 err)
(pointer->canonical-sexp (dereference-pointer sig))
(throw 'gry-error err))))))
(define verify
(let* ((ptr (libgcrypt-func "gcry_pk_verify"))
(proc (pointer->procedure int ptr '(* * *))))
(lambda (signature data public-key)
"Verify that SIGNATURE is a signature of DATA with PUBLIC-KEY, all of
which are gcrypt s-expressions."
(zero? (proc (canonical-sexp->pointer signature)
(canonical-sexp->pointer data)
(canonical-sexp->pointer public-key))))))
(define generate-key
(let* ((ptr (libgcrypt-func "gcry_pk_genkey"))
(proc (pointer->procedure int ptr '(* *))))
(lambda (params)
"Return as an s-expression a new key pair for PARAMS. PARAMS must be an
s-expression like: (genkey (rsa (nbits 4:2048)))."
(let* ((key (bytevector->pointer (make-bytevector (sizeof '*))))
(err (proc key (canonical-sexp->pointer params))))
(if (zero? err)
(pointer->canonical-sexp (dereference-pointer key))
(throw 'gcry-error err))))))
(define find-sexp-token
(let* ((ptr (libgcrypt-func "gcry_sexp_find_token"))
(proc (pointer->procedure '* ptr `(* * ,size_t))))
(lambda (sexp token)
"Find in SEXP the first element whose 'car' is TOKEN and return it;
return #f if not found."
(let* ((token (string->pointer (symbol->string token)))
(res (proc (canonical-sexp->pointer sexp) token 0)))
(if (null-pointer? res)
#f
(pointer->canonical-sexp res))))))
(define-inlinable (canonical-sexp-null? sexp)
"Return #t if SEXP is the empty-list sexp."
(null-pointer? (canonical-sexp->pointer sexp)))
(define (canonical-sexp-list? sexp)
"Return #t if SEXP is a list."
(or (canonical-sexp-null? sexp)
(> (canonical-sexp-length sexp) 0)))
(define (canonical-sexp-fold proc seed sexp)
"Fold PROC (as per SRFI-1) over SEXP, a canonical sexp."
(if (canonical-sexp-list? sexp)
(let ((len (canonical-sexp-length sexp)))
(let loop ((index 0)
(result seed))
(if (= index len)
result
(loop (+ 1 index)
;; XXX: Call 'nth-data' *before* 'nth' to work around
;; <https://bugs.g10code.com/gnupg/issue1594>, which
;; affects 1.6.0 and earlier versions.
(proc (or (canonical-sexp-nth-data sexp index)
(canonical-sexp-nth sexp index))
result)))))
(error "sexp is not a list" sexp)))
(define (canonical-sexp->sexp sexp)
"Return a Scheme sexp corresponding to SEXP. This is particularly useful to
compare sexps (since Libgcrypt does not provide an 'equal?' procedure), or to
use pattern matching."
(if (canonical-sexp-list? sexp)
(reverse
(canonical-sexp-fold (lambda (item result)
(cons (if (canonical-sexp? item)
(canonical-sexp->sexp item)
item)
result))
'()
sexp))
;; As of Libgcrypt 1.6.0, there's no function to extract the buffer of a
;; non-list sexp (!), so we first enlist SEXP, then get at its buffer.
(let ((sexp (string->canonical-sexp
(string-append "(" (canonical-sexp->string sexp)
")"))))
(or (canonical-sexp-nth-data sexp 0)
(canonical-sexp-nth sexp 0)))))
(define (sexp->canonical-sexp sexp)
"Return a canonical sexp equivalent to SEXP, a Scheme sexp as returned by
'canonical-sexp->sexp'."
;; XXX: This is inefficient, but the Libgcrypt API doesn't allow us to do
;; much better.
(string->canonical-sexp
(call-with-output-string
(lambda (port)
(define (write item)
(cond ((list? item)
(display "(" port)
(for-each write item)
(display ")" port))
((symbol? item)
(format port " ~a" item))
((bytevector? item)
(format port " #~a#"
(bytevector->base16-string item)))
(else
(error "unsupported sexp item type" item))))
(write sexp)))))
;;; pk-crypto.scm ends here

139
guix/pki.scm Normal file
View File

@ -0,0 +1,139 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix pki)
#:use-module (guix config)
#:use-module (guix pk-crypto)
#:use-module ((guix utils) #:select (with-atomic-file-output))
#:use-module ((guix build utils) #:select (mkdir-p))
#:use-module (ice-9 match)
#:use-module (rnrs io ports)
#:export (%public-key-file
%private-key-file
%acl-file
current-acl
public-keys->acl
acl->public-keys
signature-sexp
authorized-key?))
;;; Commentary:
;;;
;;; Public key infrastructure for the authentication and authorization of
;;; archive imports. This is essentially a subset of SPKI for our own
;;; purposes (see <http://theworld.com/~cme/spki.txt> and
;;; <http://www.ietf.org/rfc/rfc2693.txt>.)
;;;
;;; Code:
(define (acl-entry-sexp public-key)
"Return a SPKI-style ACL entry sexp for PUBLIC-KEY, authorizing imports
signed by the corresponding secret key (see the IETF draft at
<http://theworld.com/~cme/spki.txt> for the ACL format.)"
;; Note: We always use PUBLIC-KEY to designate the subject. Someday we may
;; want to have name certificates and to use subject names instead of
;; complete keys.
(string->canonical-sexp
(format #f
"(entry ~a (tag (guix import)))"
(canonical-sexp->string public-key))))
(define (acl-sexp entries)
"Return an ACL sexp from ENTRIES, a list of 'entry' sexps."
(string->canonical-sexp
(string-append "(acl "
(string-join (map canonical-sexp->string entries))
")")))
(define (public-keys->acl keys)
"Return an ACL canonical sexp that lists all of KEYS with a '(guix import)'
tag---meaning that all of KEYS are authorized for archive imports. Each
element in KEYS must be a canonical sexp with type 'public-key'."
(acl-sexp (map acl-entry-sexp keys)))
(define %acl-file
(string-append %config-directory "/acl"))
(define %public-key-file
(string-append %config-directory "/signing-key.pub"))
(define %private-key-file
(string-append %config-directory "/signing-key.sec"))
(define (ensure-acl)
"Make sure the ACL file exists, and create an initialized one if needed."
(unless (file-exists? %acl-file)
;; If there's no public key file, don't attempt to create the ACL.
(when (file-exists? %public-key-file)
(let ((public-key (call-with-input-file %public-key-file
(compose string->canonical-sexp
get-string-all))))
(mkdir-p (dirname %acl-file))
(with-atomic-file-output %acl-file
(lambda (port)
(display (canonical-sexp->string
(public-keys->acl (list public-key)))
port)))))))
(define (current-acl)
"Return the current ACL as a canonical sexp."
(ensure-acl)
(if (file-exists? %acl-file)
(call-with-input-file %acl-file
(compose string->canonical-sexp
get-string-all))
(public-keys->acl '()))) ; the empty ACL
(define (acl->public-keys acl)
"Return the public keys (as canonical sexps) listed in ACL with the '(guix
import)' tag."
(match (canonical-sexp->sexp acl)
(('acl
('entry subject-keys
('tag ('guix 'import)))
...)
(map sexp->canonical-sexp subject-keys))
(_
(error "invalid access-control list" acl))))
(define* (authorized-key? key
#:optional (acl (current-acl)))
"Return #t if KEY (a canonical sexp) is an authorized public key for archive
imports according to ACL."
(let ((key (canonical-sexp->sexp key)))
(match (canonical-sexp->sexp acl)
(('acl
('entry subject-keys
('tag ('guix 'import)))
...)
(not (not (member key subject-keys))))
(_
(error "invalid access-control list" acl)))))
(define (signature-sexp data secret-key public-key)
"Return a SPKI-style sexp for the signature of DATA with SECRET-KEY that
includes DATA, the actual signature value (with a 'sig-val' tag), and
PUBLIC-KEY (see <http://theworld.com/~cme/spki.txt> for examples.)"
(string->canonical-sexp
(format #f
"(signature ~a ~a ~a)"
(canonical-sexp->string data)
(canonical-sexp->string (sign data secret-key))
(canonical-sexp->string public-key))))
;;; pki.scm ends here

337
guix/scripts/archive.scm Normal file
View File

@ -0,0 +1,337 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix scripts archive)
#:use-module (guix config)
#:use-module (guix utils)
#:use-module ((guix build utils) #:select (mkdir-p))
#:use-module (guix store)
#:use-module (guix packages)
#:use-module (guix derivations)
#:use-module (guix ui)
#:use-module (guix pki)
#:use-module (guix pk-crypto)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:use-module (ice-9 rdelim)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-37)
#:use-module (guix scripts build)
#:use-module (guix scripts package)
#:use-module (rnrs io ports)
#:export (guix-archive))
;;;
;;; Command-line options.
;;;
(define %default-options
;; Alist of default option values.
`((system . ,(%current-system))
(substitutes? . #t)
(max-silent-time . 3600)
(verbosity . 0)))
(define (show-help)
(display (_ "Usage: guix archive [OPTION]... PACKAGE...
Export/import one or more packages from/to the store.\n"))
(display (_ "
--export export the specified files/packages to stdout"))
(display (_ "
--import import from the archive passed on stdin"))
(display (_ "
--missing print the files from stdin that are missing"))
(newline)
(display (_ "
--generate-key[=PARAMETERS]
generate a key pair with the given parameters"))
(display (_ "
-e, --expression=EXPR build the package or derivation EXPR evaluates to"))
(display (_ "
-S, --source build the packages' source derivations"))
(display (_ "
-s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\""))
(display (_ "
--target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\""))
(display (_ "
-n, --dry-run do not build the derivations"))
(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 (_ "
-c, --cores=N allow the use of up to N CPU cores for the build"))
(newline)
(display (_ "
-h, --help display this help and exit"))
(display (_ "
-V, --version display version information and exit"))
(newline)
(show-bug-report-information))
(define %options
;; Specifications of the command-line options.
(list (option '(#\h "help") #f #f
(lambda args
(show-help)
(exit 0)))
(option '(#\V "version") #f #f
(lambda args
(show-version-and-exit "guix build")))
(option '("export") #f #f
(lambda (opt name arg result)
(alist-cons 'export #t result)))
(option '("import") #f #f
(lambda (opt name arg result)
(alist-cons 'import #t result)))
(option '("missing") #f #f
(lambda (opt name arg result)
(alist-cons 'missing #t result)))
(option '("generate-key") #f #t
(lambda (opt name arg result)
(catch 'gcry-error
(lambda ()
(let ((params
(string->canonical-sexp
(or arg "(genkey (rsa (nbits 4:4096)))"))))
(alist-cons 'generate-key params result)))
(lambda args
(leave (_ "invalid key generation parameters: ~s~%")
arg)))))
(option '("authorize") #f #f
(lambda (opt name arg result)
(alist-cons 'authorize #t result)))
(option '(#\S "source") #f #f
(lambda (opt name arg result)
(alist-cons 'source? #t result)))
(option '(#\s "system") #t #f
(lambda (opt name arg result)
(alist-cons 'system arg
(alist-delete 'system result eq?))))
(option '("target") #t #f
(lambda (opt name arg result)
(alist-cons 'target arg
(alist-delete 'target result eq?))))
(option '(#\e "expression") #t #f
(lambda (opt name arg result)
(alist-cons 'expression arg result)))
(option '(#\c "cores") #t #f
(lambda (opt name arg result)
(let ((c (false-if-exception (string->number arg))))
(if c
(alist-cons 'cores c result)
(leave (_ "~a: not a number~%") arg)))))
(option '(#\n "dry-run") #f #f
(lambda (opt name arg result)
(alist-cons 'dry-run? #t result)))
(option '("fallback") #f #f
(lambda (opt name arg result)
(alist-cons 'fallback? #t
(alist-delete 'fallback? result))))
(option '("no-substitutes") #f #f
(lambda (opt name arg result)
(alist-cons 'substitutes? #f
(alist-delete 'substitutes? result))))
(option '("max-silent-time") #t #f
(lambda (opt name arg result)
(alist-cons 'max-silent-time (string->number* arg)
result)))
(option '(#\r "root") #t #f
(lambda (opt name arg result)
(alist-cons 'gc-root arg result)))
(option '("verbosity") #t #f
(lambda (opt name arg result)
(let ((level (string->number arg)))
(alist-cons 'verbosity level
(alist-delete 'verbosity result)))))))
(define (options->derivations+files store opts)
"Given OPTS, the result of 'args-fold', return a list of derivations to
build and a list of store files to transfer."
(define package->derivation
(match (assoc-ref opts 'target)
(#f package-derivation)
(triplet
(cut package-cross-derivation <> <> triplet <>))))
(define src? (assoc-ref opts 'source?))
(define sys (assoc-ref opts 'system))
(fold2 (lambda (arg derivations files)
(match arg
(('expression . str)
(let ((drv (derivation-from-expression store str
package->derivation
sys src?)))
(values (cons drv derivations)
(cons (derivation->output-path drv) files))))
(('argument . (? store-path? file))
(values derivations (cons file files)))
(('argument . (? string? spec))
(let-values (((p output)
(specification->package+output spec)))
(if src?
(let* ((s (package-source p))
(drv (package-source-derivation store s)))
(values (cons drv derivations)
(cons (derivation->output-path drv)
files)))
(let ((drv (package->derivation store p sys)))
(values (cons drv derivations)
(cons (derivation->output-path drv output)
files))))))
(_
(values derivations files))))
'()
'()
opts))
;;;
;;; Entry point.
;;;
(define (export-from-store store opts)
"Export the packages or derivations specified in OPTS from STORE. Write the
resulting archive to the standard output port."
(let-values (((drv files)
(options->derivations+files store opts)))
(show-what-to-build store drv
#:use-substitutes? (assoc-ref opts 'substitutes?)
#:dry-run? (assoc-ref opts 'dry-run?))
(set-build-options store
#:build-cores (or (assoc-ref opts 'cores) 0)
#:fallback? (assoc-ref opts 'fallback?)
#:use-substitutes? (assoc-ref opts 'substitutes?)
#:max-silent-time (assoc-ref opts 'max-silent-time))
(if (or (assoc-ref opts 'dry-run?)
(build-derivations store drv))
(export-paths store files (current-output-port))
(leave (_ "unable to export the given packages~%")))))
(define (generate-key-pair parameters)
"Generate a key pair with PARAMETERS, a canonical sexp, and store it in the
right place."
(when (or (file-exists? %public-key-file)
(file-exists? %private-key-file))
(leave (_ "key pair exists under '~a'; remove it first~%")
(dirname %public-key-file)))
(format (current-error-port)
(_ "Please wait while gathering entropy to generate the key pair;
this may take time...~%"))
(let* ((pair (catch 'gcry-error
(lambda ()
(generate-key parameters))
(lambda (key err)
(leave (_ "key generation failed: ~a: ~a~%")
(error-source err)
(error-string err)))))
(public (find-sexp-token pair 'public-key))
(secret (find-sexp-token pair 'private-key)))
;; Create the following files as #o400.
(umask #o266)
(mkdir-p (dirname %public-key-file))
(with-atomic-file-output %public-key-file
(lambda (port)
(display (canonical-sexp->string public) port)))
(with-atomic-file-output %private-key-file
(lambda (port)
(display (canonical-sexp->string secret) port)))
;; Make the public key readable by everyone.
(chmod %public-key-file #o444)))
(define (authorize-key)
"Authorize imports signed by the public key passed as an advanced sexp on
the input port."
(define (read-key)
(catch 'gcry-error
(lambda ()
(string->canonical-sexp (get-string-all (current-input-port))))
(lambda (key err)
(leave (_ "failed to read public key: ~a: ~a~%")
(error-source err) (error-string err)))))
(let ((key (read-key))
(acl (current-acl)))
(unless (eq? 'public-key (canonical-sexp-nth-data key 0))
(leave (_ "s-expression does not denote a public key~%")))
;; Add KEY to the ACL and write that.
(let ((acl (public-keys->acl (cons key (acl->public-keys acl)))))
(with-atomic-file-output %acl-file
(lambda (port)
(display (canonical-sexp->string acl) port))))))
(define (guix-archive . args)
(define (parse-options)
;; Return the alist of option values.
(args-fold* args %options
(lambda (opt name arg result)
(leave (_ "~A: unrecognized option~%") name))
(lambda (arg result)
(alist-cons 'argument arg result))
%default-options))
(define (lines port)
;; Return lines read from PORT.
(let loop ((line (read-line port))
(result '()))
(if (eof-object? line)
(reverse result)
(loop (read-line port)
(cons line result)))))
(with-error-handling
;; Ask for absolute file names so that .drv file names passed from the
;; user to 'read-derivation' are absolute when it returns.
(with-fluids ((%file-port-name-canonicalization 'absolute))
(let ((opts (parse-options)))
(cond ((assoc-ref opts 'generate-key)
=>
generate-key-pair)
((assoc-ref opts 'authorize)
(authorize-key))
(else
(let ((store (open-connection)))
(cond ((assoc-ref opts 'export)
(export-from-store store opts))
((assoc-ref opts 'import)
(import-paths store (current-input-port)))
((assoc-ref opts 'missing)
(let* ((files (lines (current-input-port)))
(missing (remove (cut valid-path? store <>)
files)))
(format #t "~{~a~%~}" missing)))
(else
(leave
(_ "either '--export' or '--import' \
must be specified~%")))))))))))

101
guix/scripts/authenticate.scm Normal file
View File

@ -0,0 +1,101 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix scripts authenticate)
#:use-module (guix config)
#:use-module (guix utils)
#:use-module (guix pk-crypto)
#:use-module (guix pki)
#:use-module (guix ui)
#:use-module (rnrs io ports)
#:use-module (ice-9 match)
#:export (guix-authenticate))
;;; Commentary:
;;;
;;; This program is used internally by the daemon to sign exported archive
;;; (the 'export-paths' RPC), and to authenticate imported archives (the
;;; 'import-paths' RPC.)
;;;
;;; Code:
(define (read-canonical-sexp file)
"Read a gcrypt sexp from FILE and return it."
(call-with-input-file file
(compose string->canonical-sexp get-string-all)))
(define (read-hash-data file)
"Read sha256 hash data from FILE and return it as a gcrypt sexp."
(let* ((hex (call-with-input-file file get-string-all))
(bv (base16-string->bytevector (string-trim-both hex))))
(bytevector->hash-data bv)))
;;;
;;; Entry point with 'openssl'-compatible interface. We support this
;;; interface because that's what the daemon expects, and we want to leave it
;;; unmodified currently.
;;;
(define (guix-authenticate . args)
(match args
(("rsautl" "-sign" "-inkey" key "-in" hash-file)
;; Sign the hash in HASH-FILE with KEY, and return an sexp that includes
;; both the hash and the actual signature.
(let* ((secret-key (read-canonical-sexp key))
(public-key (if (string-suffix? ".sec" key)
(read-canonical-sexp
(string-append (string-drop-right key 4) ".pub"))
(leave
(_ "cannot find public key for secret key '~a'~%")
key)))
(data (read-hash-data hash-file))
(signature (signature-sexp data secret-key public-key)))
(display (canonical-sexp->string signature))
#t))
(("rsautl" "-verify" "-inkey" _ "-pubin" "-in" signature-file)
;; Read the signature as produced above, check whether its public key is
;; authorized, and verify the signature, and print the signed data to
;; stdout upon success.
(let* ((sig+data (read-canonical-sexp signature-file))
(public-key (find-sexp-token sig+data 'public-key))
(data (find-sexp-token sig+data 'data))
(signature (find-sexp-token sig+data 'sig-val)))
(if (and data signature)
(if (authorized-key? public-key)
(if (verify signature data public-key)
(begin
(display (bytevector->base16-string
(hash-data->bytevector data)))
#t) ; success
(leave (_ "error: invalid signature: ~a~%")
(canonical-sexp->string signature)))
(leave (_ "error: unauthorized public key: ~a~%")
(canonical-sexp->string public-key)))
(leave (_ "error: corrupt signature data: ~a~%")
(canonical-sexp->string sig+data)))))
(("--help")
(display (_ "Usage: guix authenticate OPTION...
Sign or verify the signature on the given file. This tool is meant to
be used internally by 'guix-daemon'.\n")))
(("--version")
(show-version-and-exit "guix authenticate"))
(else
(leave (_ "wrong arguments")))))
;;; authenticate.scm ends here

203
guix/scripts/build.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
;;;
;;; This file is part of GNU Guix.
@ -32,14 +32,11 @@
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-37)
#:autoload (gnu packages) (find-packages-by-name
find-newest-available-packages)
#:export (guix-build))
#:autoload (gnu packages) (find-best-packages-by-name)
#:export (derivation-from-expression
guix-build))
(define %store
(make-parameter #f))
(define (derivation-from-expression str package-derivation
(define (derivation-from-expression store str package-derivation
system source?)
"Read/eval STR and return the corresponding derivation path for SYSTEM.
When SOURCE? is true and STR evaluates to a package, return the derivation of
@ -50,12 +47,57 @@ derivation of a package."
(if source?
(let ((source (package-source p)))
(if source
(package-source-derivation (%store) source)
(package-source-derivation store source)
(leave (_ "package `~a' has no source~%")
(package-name p))))
(package-derivation (%store) p system)))
(package-derivation store p system)))
((? procedure? proc)
(run-with-store (%store) (proc) #:system system))))
(run-with-store store (proc) #:system system))))
(define (specification->package spec)
"Return a package matching SPEC. SPEC may be a package name, or a package
name followed by a hyphen and a version number. If the version number is not
present, return the preferred newest version."
(let-values (((name version)
(package-name->name+version spec)))
(match (find-best-packages-by-name name version)
((p) ; one match
p)
((p x ...) ; several matches
(warning (_ "ambiguous package specification `~a'~%") spec)
(warning (_ "choosing ~a from ~a~%")
(package-full-name p)
(location->string (package-location p)))
p)
(_ ; no matches
(if version
(leave (_ "~A: package not found for version ~a~%")
name version)
(leave (_ "~A: unknown package~%") name))))))
(define (register-root store paths root)
"Register ROOT as an indirect GC root for all of PATHS."
(let* ((root (string-append (canonicalize-path (dirname root))
"/" root)))
(catch 'system-error
(lambda ()
(match paths
((path)
(symlink path root)
(add-indirect-root store root))
((paths ...)
(fold (lambda (path count)
(let ((root (string-append root
"-"
(number->string count))))
(symlink path root)
(add-indirect-root store root))
(+ 1 count))
0
paths))))
(lambda args
(leave (_ "failed to create GC root `~a': ~a~%")
root (strerror (system-error-errno args)))))))
;;;
@ -66,6 +108,7 @@ derivation of a package."
;; Alist of default option values.
`((system . ,(%current-system))
(substitutes? . #t)
(build-hook? . #t)
(max-silent-time . 3600)
(verbosity . 0)))
@ -90,6 +133,8 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
--fallback fall back to building when the substituter fails"))
(display (_ "
--no-substitutes build instead of resorting to pre-built substitutes"))
(display (_ "
--no-build-hook do not attempt to offload builds via the build hook"))
(display (_ "
--max-silent-time=SECONDS
mark the build as failed after SECONDS of silence"))
@ -157,6 +202,10 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
(lambda (opt name arg result)
(alist-cons 'substitutes? #f
(alist-delete 'substitutes? result))))
(option '("no-build-hook") #f #f
(lambda (opt name arg result)
(alist-cons 'build-hook? #f
(alist-delete 'build-hook? result))))
(option '("max-silent-time") #t #f
(lambda (opt name arg result)
(alist-cons 'max-silent-time (string->number* arg)
@ -173,6 +222,36 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
(lambda (opt name arg result)
(alist-cons 'log-file? #t result)))))
(define (options->derivations store opts)
"Given OPTS, the result of 'args-fold', return a list of derivations to
build."
(define package->derivation
(match (assoc-ref opts 'target)
(#f package-derivation)
(triplet
(cut package-cross-derivation <> <> triplet <>))))
(define src? (assoc-ref opts 'source?))
(define sys (assoc-ref opts 'system))
(filter-map (match-lambda
(('expression . str)
(derivation-from-expression store str package->derivation
sys src?))
(('argument . (? derivation-path? drv))
(call-with-input-file drv read-derivation))
(('argument . (? store-path?))
;; Nothing to do; maybe for --log-file.
#f)
(('argument . (? string? x))
(let ((p (specification->package x)))
(if src?
(let ((s (package-source p)))
(package-source-derivation store s))
(package->derivation store p sys))))
(_ #f))
opts))
;;;
;;; Entry point.
@ -188,116 +267,36 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
(alist-cons 'argument arg result))
%default-options))
(define (register-root paths root)
;; Register ROOT as an indirect GC root for all of PATHS.
(let* ((root (string-append (canonicalize-path (dirname root))
"/" root)))
(catch 'system-error
(lambda ()
(match paths
((path)
(symlink path root)
(add-indirect-root (%store) root))
((paths ...)
(fold (lambda (path count)
(let ((root (string-append root
"-"
(number->string count))))
(symlink path root)
(add-indirect-root (%store) root))
(+ 1 count))
0
paths))))
(lambda args
(leave (_ "failed to create GC root `~a': ~a~%")
root (strerror (system-error-errno args)))))))
(define newest-available-packages
(memoize find-newest-available-packages))
(define (find-best-packages-by-name name version)
(if version
(find-packages-by-name name version)
(match (vhash-assoc name (newest-available-packages))
((_ version pkgs ...) pkgs)
(#f '()))))
(define (find-package request)
;; Return a package matching REQUEST. REQUEST may be a package
;; name, or a package name followed by a hyphen and a version
;; number. If the version number is not present, return the
;; preferred newest version.
(let-values (((name version)
(package-name->name+version request)))
(match (find-best-packages-by-name name version)
((p) ; one match
p)
((p x ...) ; several matches
(warning (_ "ambiguous package specification `~a'~%") request)
(warning (_ "choosing ~a from ~a~%")
(package-full-name p)
(location->string (package-location p)))
p)
(_ ; no matches
(if version
(leave (_ "~A: package not found for version ~a~%")
name version)
(leave (_ "~A: unknown package~%") name))))))
(with-error-handling
;; Ask for absolute file names so that .drv file names passed from the
;; user to 'read-derivation' are absolute when it returns.
(with-fluids ((%file-port-name-canonicalization 'absolute))
(let ((opts (parse-options)))
(define package->derivation
(match (assoc-ref opts 'target)
(#f package-derivation)
(triplet
(cut package-cross-derivation <> <> triplet <>))))
(parameterize ((%store (open-connection)))
(let* ((src? (assoc-ref opts 'source?))
(sys (assoc-ref opts 'system))
(drv (filter-map (match-lambda
(('expression . str)
(derivation-from-expression
str package->derivation sys src?))
(('argument . (? derivation-path? drv))
(call-with-input-file drv read-derivation))
(('argument . (? store-path?))
;; Nothing to do; maybe for --log-file.
#f)
(('argument . (? string? x))
(let ((p (find-package x)))
(if src?
(let ((s (package-source p)))
(package-source-derivation
(%store) s))
(package->derivation (%store) p sys))))
(_ #f))
opts))
(let* ((opts (parse-options))
(store (open-connection))
(drv (options->derivations store opts))
(roots (filter-map (match-lambda
(('gc-root . root) root)
(_ #f))
opts)))
(unless (assoc-ref opts 'log-file?)
(show-what-to-build (%store) drv
(show-what-to-build store drv
#:use-substitutes? (assoc-ref opts 'substitutes?)
#:dry-run? (assoc-ref opts 'dry-run?)))
;; TODO: Add more options.
(set-build-options (%store)
(set-build-options store
#:keep-failed? (assoc-ref opts 'keep-failed?)
#:build-cores (or (assoc-ref opts 'cores) 0)
#:fallback? (assoc-ref opts 'fallback?)
#:use-substitutes? (assoc-ref opts 'substitutes?)
#:use-build-hook? (assoc-ref opts 'build-hook?)
#:max-silent-time (assoc-ref opts 'max-silent-time)
#:verbosity (assoc-ref opts 'verbosity))
(cond ((assoc-ref opts 'log-file?)
(for-each (lambda (file)
(let ((log (log-file (%store) file)))
(let ((log (log-file store file)))
(if log
(format #t "~a~%" log)
(leave (_ "no build log for '~a'~%")
@ -312,11 +311,11 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
opts)))))
((assoc-ref opts 'derivations-only?)
(format #t "~{~a~%~}" (map derivation-file-name drv))
(for-each (cut register-root <> <>)
(for-each (cut register-root store <> <>)
(map (compose list derivation-file-name) drv)
roots))
((not (assoc-ref opts 'dry-run?))
(and (build-derivations (%store) drv)
(and (build-derivations store drv)
(for-each (lambda (d)
(format #t "~{~a~%~}"
(map (match-lambda
@ -325,9 +324,9 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
d out-name)))
(derivation-outputs d))))
drv)
(for-each (cut register-root <> <>)
(for-each (cut register-root store <> <>)
(map (lambda (drv)
(map cdr
(derivation->output-paths drv)))
drv)
roots))))))))))
roots))))))))

50
guix/scripts/package.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
;;;
@ -41,7 +41,8 @@
#:use-module ((gnu packages base) #:select (guile-final))
#:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile))
#:use-module (guix gnu-maintenance)
#:export (guix-package))
#:export (specification->package+output
guix-package))
(define %store
(make-parameter #f))
@ -56,7 +57,7 @@
(cut string-append <> "/.guix-profile")))
(define %profile-directory
(string-append (or (getenv "NIX_STATE_DIR") %state-directory) "/profiles/"
(string-append %state-directory "/profiles/"
(or (and=> (getenv "USER")
(cut string-append "per-user/" <>))
"default")))
@ -292,21 +293,24 @@ return its return value."
(format (current-error-port) " interrupted by signal ~a~%" SIGINT)
#f))))
(define newest-available-packages
(memoize find-newest-available-packages))
(define (find-best-packages-by-name name version)
"If version is #f, return the list of packages named NAME with the highest
version numbers; otherwise, return the list of packages named NAME and at
VERSION."
(if version
(find-packages-by-name name version)
(match (vhash-assoc name (newest-available-packages))
((_ version pkgs ...) pkgs)
(#f '()))))
(define-syntax-rule (leave-on-EPIPE exp ...)
"Run EXP... in a context when EPIPE errors are caught and lead to 'exit'
with successful exit code. This is useful when writing to the standard output
may lead to EPIPE, because the standard output is piped through 'head' or
similar."
(catch 'system-error
(lambda ()
exp ...)
(lambda args
;; We really have to exit this brutally, otherwise Guile eventually
;; attempts to flush all the ports, leading to an uncaught EPIPE down
;; the path.
(if (= EPIPE (system-error-errno args))
(primitive-_exit 0)
(apply throw args)))))
(define* (specification->package+output spec #:optional (output "out"))
"Find the package and output specified by SPEC, or #f and #f; SPEC may
"Return the package and output specified by SPEC, or #f and #f; SPEC may
optionally contain a version number and an output name, as in these examples:
guile
@ -342,7 +346,7 @@ version; if SPEC does not specify an output, return OUTPUT."
"Return #t if there's a version of package NAME newer than CURRENT-VERSION,
or if the newest available version is equal to CURRENT-VERSION but would have
an output path different than CURRENT-PATH."
(match (vhash-assoc name (newest-available-packages))
(match (vhash-assoc name (find-newest-available-packages))
((_ candidate-version pkg . rest)
(case (version-compare candidate-version current-version)
((>) #t)
@ -970,15 +974,17 @@ more information.~%"))
profile))
((string-null? pattern)
(let ((numbers (generation-numbers profile)))
(leave-on-EPIPE
(if (equal? numbers '(0))
(exit 0)
(for-each list-generation numbers))))
(for-each list-generation numbers)))))
((matching-generations pattern profile)
=>
(lambda (numbers)
(if (null-list? numbers)
(exit 1)
(for-each list-generation numbers))))
(leave-on-EPIPE
(for-each list-generation numbers)))))
(else
(leave (_ "invalid syntax: ~a~%")
pattern)))
@ -988,6 +994,7 @@ more information.~%"))
(let* ((regexp (and regexp (make-regexp regexp)))
(manifest (profile-manifest profile))
(installed (manifest-entries manifest)))
(leave-on-EPIPE
(for-each (match-lambda
(($ <manifest-entry> name version output path _)
(when (or (not regexp)
@ -996,7 +1003,7 @@ more information.~%"))
name (or version "?") output path))))
;; Show most recently installed packages last.
(reverse installed))
(reverse installed)))
#t))
(('list-available regexp)
@ -1010,6 +1017,7 @@ more information.~%"))
r)
(cons p r))))
'())))
(leave-on-EPIPE
(for-each (lambda (p)
(format #t "~a\t~a\t~a\t~a~%"
(package-name p)
@ -1019,7 +1027,7 @@ more information.~%"))
(sort available
(lambda (p1 p2)
(string<? (package-name p1)
(package-name p2)))))
(package-name p2))))))
#t))
(('search regexp)

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

@ -72,21 +72,6 @@
;; How often we want to remove files corresponding to expired cache entries.
(* 7 24 3600))
(define (with-atomic-file-output file proc)
"Call PROC with an output port for the file that is going to replace FILE.
Upon success, FILE is atomically replaced by what has been written to the
output port, and PROC's result is returned."
(let* ((template (string-append file ".XXXXXX"))
(out (mkstemp! template)))
(with-throw-handler #t
(lambda ()
(let ((result (proc out)))
(close out)
(rename-file template file)
result))
(lambda (key . args)
(false-if-exception (delete-file template))))))
;; In Guile 2.0.9, `regexp-exec' is thread-unsafe, so work around it.
;; See <http://bugs.gnu.org/14404>.
(set! regexp-exec
@ -594,7 +579,6 @@ Internal tool to substitute a pre-built binary to a local build.\n"))
;;; Local Variables:
;;; eval: (put 'with-atomic-file-output 'scheme-indent-function 1)
;;; eval: (put 'with-timeout 'scheme-indent-function 1)
;;; End:

99
guix/store.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@ -80,6 +80,8 @@
dead-paths
collect-garbage
delete-paths
import-paths
export-paths
current-build-output-port
@ -156,8 +158,7 @@
(delete-specific 3))
(define %default-socket-path
(string-append (or (getenv "NIX_STATE_DIR") %state-directory)
"/daemon-socket/socket"))
(string-append %state-directory "/daemon-socket/socket"))
(define %daemon-socket-file
;; File name of the socket the daemon listens too.
@ -323,7 +324,30 @@ operate, should the disk become full. Return a server object."
;; The port where build output is sent.
(make-parameter (current-error-port)))
(define (process-stderr server)
(define* (dump-port in out
#:optional len
#:key (buffer-size 16384))
"Read LEN bytes from IN (or as much as possible if LEN is #f) and write it
to OUT, using chunks of BUFFER-SIZE bytes."
(define buffer
(make-bytevector buffer-size))
(let loop ((total 0)
(bytes (get-bytevector-n! in buffer 0
(if len
(min len buffer-size)
buffer-size))))
(or (eof-object? bytes)
(and len (= total len))
(let ((total (+ total bytes)))
(put-bytevector out buffer 0 bytes)
(loop total
(get-bytevector-n! in buffer 0
(if len
(min (- len total) buffer-size)
buffer-size)))))))
(define* (process-stderr server #:optional user-port)
"Read standard output and standard error from SERVER, writing it to
CURRENT-BUILD-OUTPUT-PORT. Return #t when SERVER is done sending data, and
#f otherwise; in the latter case, the caller should call `process-stderr'
@ -344,17 +368,30 @@ encoding conversion errors."
(let ((k (read-int p)))
(cond ((= k %stderr-write)
(read-latin1-string p)
;; Write a byte stream to USER-PORT.
(let* ((len (read-int p))
(m (modulo len 8)))
(dump-port p user-port len)
(unless (zero? m)
;; Consume padding, as for strings.
(get-bytevector-n p (- 8 m))))
#f)
((= k %stderr-read)
(let ((len (read-int p)))
(read-latin1-string p) ; FIXME: what to do?
;; Read a byte stream from USER-PORT.
(let* ((max-len (read-int p))
(data (get-bytevector-n user-port max-len))
(len (bytevector-length data)))
(write-int len p)
(put-bytevector p data)
(write-padding len p)
#f))
((= k %stderr-next)
;; Log a string.
(let ((s (read-latin1-string p)))
(display s (current-build-output-port))
#f))
((= k %stderr-error)
;; Report an error.
(let ((error (read-latin1-string p))
;; Currently the daemon fails to send a status code for early
;; errors like DB schema version mismatches, so check for EOF.
@ -624,6 +661,39 @@ MIN-FREED bytes have been collected. Return the paths that were
collected, and the number of bytes freed."
(run-gc server (gc-action delete-specific) paths min-freed))
(define (import-paths server port)
"Import the set of store paths read from PORT into SERVER's store. An error
is raised if the set of paths read from PORT is not signed (as per
'export-path #:sign? #t'.) Return the list of store paths imported."
(let ((s (nix-server-socket server)))
(write-int (operation-id import-paths) s)
(let loop ((done? (process-stderr server port)))
(or done? (loop (process-stderr server port))))
(read-store-path-list s)))
(define* (export-path server path port #:key (sign? #t))
"Export PATH to PORT. When SIGN? is true, sign it."
(let ((s (nix-server-socket server)))
(write-int (operation-id export-path) s)
(write-store-path path s)
(write-arg boolean sign? s)
(let loop ((done? (process-stderr server port)))
(or done? (loop (process-stderr server port))))
(= 1 (read-int s))))
(define* (export-paths server paths port #:key (sign? #t))
"Export the store paths listed in PATHS to PORT, signing them if SIGN?
is true."
(let ((s (nix-server-socket server)))
(let loop ((paths paths))
(match paths
(()
(write-int 0 port))
((head tail ...)
(write-int 1 port)
(and (export-path server head port #:sign? sign?)
(loop tail)))))))
;;;
;;; Store paths.
@ -631,8 +701,7 @@ collected, and the number of bytes freed."
(define %store-prefix
;; Absolute path to the Nix store.
(make-parameter (or (and=> (getenv "NIX_STORE_DIR") canonicalize-path)
%store-directory)))
(make-parameter %store-directory))
(define (store-path? path)
"Return #t if PATH is a store path."
@ -678,16 +747,16 @@ syntactically valid store path."
(define (log-file store file)
"Return the build log file for FILE, or #f if none could be found. FILE
must be an absolute store file name, or a derivation file name."
(define state-dir ; XXX: factorize
(or (getenv "NIX_STATE_DIR") %state-directory))
(cond ((derivation-path? file)
(let* ((base (basename file))
(log (string-append (dirname state-dir) ; XXX: ditto
(log (string-append (dirname %state-directory) ; XXX
"/log/nix/drvs/"
(string-take base 2) "/"
(string-drop base 2) ".bz2")))
(and (file-exists? log) log)))
(string-drop base 2)))
(log.bz2 (string-append log ".bz2")))
(cond ((file-exists? log.bz2) log.bz2)
((file-exists? log) log)
(else #f))))
(else
(match (valid-derivers store file)
((derivers ...)

16
guix/utils.scm
View File

@ -67,6 +67,7 @@
file-extension
file-sans-extension
call-with-temporary-output-file
with-atomic-file-output
fold2
filtered-port))
@ -426,6 +427,21 @@ call."
(false-if-exception (close out))
(false-if-exception (delete-file template))))))
(define (with-atomic-file-output file proc)
"Call PROC with an output port for the file that is going to replace FILE.
Upon success, FILE is atomically replaced by what has been written to the
output port, and PROC's result is returned."
(let* ((template (string-append file ".XXXXXX"))
(out (mkstemp! template)))
(with-throw-handler #t
(lambda ()
(let ((result (proc out)))
(close out)
(rename-file template file)
result))
(lambda (key . args)
(false-if-exception (delete-file template))))))
(define fold2
(case-lambda
((proc seed1 seed2 lst)

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

@ -45,6 +45,7 @@ guix_hash_final (void *resbuf, struct guix_hash_context *ctx,
memcpy (resbuf, gcry_md_read (ctx->md_handle, algo),
gcry_md_get_algo_dlen (algo));
gcry_md_close (ctx->md_handle);
ctx->md_handle = NULL;
}
}

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

@ -23,17 +23,28 @@
#include <gcrypt.h>
#include <unistd.h>
extern "C" {
struct guix_hash_context
{
/* This copy constructor is needed in 'HashSink::currentHash()' where we
expect the copy of a 'Ctx' object to yield a truly different context. */
guix_hash_context (guix_hash_context &ref)
{
if (ref.md_handle == NULL)
md_handle = NULL;
else
gcry_md_copy (&md_handle, ref.md_handle);
}
/* Make sure 'md_handle' is always initialized. */
guix_hash_context (): md_handle (NULL) { };
gcry_md_hd_t md_handle;
};
extern "C" {
extern void guix_hash_init (struct guix_hash_context *ctx, int algo);
extern void guix_hash_update (struct guix_hash_context *ctx, const void *buffer,
size_t len);
extern void guix_hash_final (void *resbuf, struct guix_hash_context *ctx,
int algo);
}

10
nix/nix-daemon/guix-daemon.cc
View File

@ -195,6 +195,10 @@ main (int argc, char *argv[])
exit (EXIT_FAILURE);
}
/* Tell Libgcrypt that initialization has completed, as per the Libgcrypt
1.6.0 manual (although this does not appear to be strictly needed.) */
gcry_control (GCRYCTL_INITIALIZATION_FINISHED, 0);
/* Set the umask so that the daemon does not end up creating group-writable
files, which would lead to "suspicious ownership or permission" errors.
See <http://lists.gnu.org/archive/html/bug-guix/2013-07/msg00033.html>. */
@ -212,6 +216,12 @@ main (int argc, char *argv[])
{
settings.processEnvironment ();
/* Hackily help 'local-store.cc' find our 'guix-authenticate' program, which
is known as 'OPENSSL_PATH' here. */
std::string search_path (getenv ("PATH"));
search_path = settings.nixLibexecDir + ":" + search_path;
setenv ("PATH", search_path.c_str (), 1);
/* Use our substituter by default. */
settings.substituters.clear ();
settings.useSubstitutes = true;

11
nix/scripts/guix-authenticate.in Normal file
View File

@ -0,0 +1,11 @@
#!@SHELL@
# A shorthand for "guix authenticate", for use by the daemon.
if test "x$GUIX_UNINSTALLED" = "x"
then
prefix="@prefix@"
exec_prefix="@exec_prefix@"
exec "@bindir@/guix" authenticate "$@"
else
exec guix authenticate "$@"
fi

8
nix/sync-with-upstream
View File

@ -70,3 +70,11 @@ cp -v "$top_srcdir/nix-upstream/AUTHORS" "$top_srcdir/nix"
# Substitutions.
sed -i "$top_srcdir/nix/libstore/gc.cc" \
-e 's|/nix/find-runtime-roots\.pl|/guix/list-runtime-roots|g'
# Our 'guix_hash_context' structure has a copy constructor, specifically to
# handle the use case in 'HashSink::currentHash()' where the copy of the
# context is expected to truly copy the underlying hash context. The copy
# constructor cannot be used in 'Ctx' if that's a union, so turn it into a
# structure (we can afford to two wasted words.)
sed -i "$top_srcdir/nix/libutil/hash.cc" "$top_srcdir/nix/libutil/hash.hh" \
-e 's|union Ctx|struct Ctx|g'

1
po/POTFILES.in
View File

@ -11,6 +11,7 @@ guix/scripts/gc.scm
guix/scripts/hash.scm
guix/scripts/pull.scm
guix/scripts/substitute-binary.scm
guix/scripts/authenticate.scm
guix/gnu-maintenance.scm
guix/ui.scm
guix/http-client.scm

18
test-env.in
View File

@ -40,6 +40,22 @@ then
# Currently, in Nix builds, we're at ~106 chars...
NIX_STATE_DIR="@GUIX_TEST_ROOT@/var/$$"
# The configuration directory, for import/export signing keys.
NIX_CONF_DIR="@GUIX_TEST_ROOT@/etc"
if [ ! -d "$NIX_CONF_DIR" ]
then
# Copy the keys so that the secret key has the right permissions (the
# daemon errors out when this is not the case.)
mkdir -p "$NIX_CONF_DIR"
cp "@abs_top_srcdir@/tests/signing-key.sec" \
"@abs_top_srcdir@/tests/signing-key.pub" \
"$NIX_CONF_DIR"
chmod 400 "$NIX_CONF_DIR/signing-key.sec"
fi
# For 'guix-authenticate'.
NIX_LIBEXEC_DIR="@abs_top_builddir@/nix/scripts"
# A place to store data of the substituter.
GUIX_BINARY_SUBSTITUTE_URL="file://$NIX_STATE_DIR/substituter-data"
rm -rf "$NIX_STATE_DIR/substituter-data"
@ -51,7 +67,7 @@ then
export NIX_IGNORE_SYMLINK_STORE NIX_STORE_DIR \
NIX_LOCALSTATE_DIR NIX_LOG_DIR NIX_STATE_DIR NIX_DB_DIR \
NIX_ROOT_FINDER NIX_SETUID_HELPER GUIX_BINARY_SUBSTITUTE_URL \
XDG_CACHE_HOME
NIX_CONF_DIR NIX_LIBEXEC_DIR XDG_CACHE_HOME
# Do that because store.scm calls `canonicalize-path' on it.
mkdir -p "$NIX_STORE_DIR"

66
tests/guix-archive.sh Normal file
View File

@ -0,0 +1,66 @@
# GNU Guix --- Functional package management for GNU
# Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
#
# This file is part of GNU Guix.
#
# GNU Guix is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or (at
# your option) any later version.
#
# GNU Guix is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
#
# Test the 'guix archive' command-line utility.
#
guix archive --version
archive="t-archive-$$"
archive_alt="t-archive-alt-$$"
rm -f "$archive" "$archive_alt"
trap 'rm -f "$archive" "$archive_alt"' EXIT
guix archive --export guile-bootstrap > "$archive"
guix archive --export guile-bootstrap:out > "$archive_alt"
cmp "$archive" "$archive_alt"
guix archive --export \
-e '(@ (gnu packages bootstrap) %bootstrap-guile)' > "$archive_alt"
cmp "$archive" "$archive_alt"
guix archive --export `guix build guile-bootstrap` > "$archive_alt"
cmp "$archive" "$archive_alt"
guix archive --import < "$archive" 2>&1 | grep "import.*guile-bootstrap"
if guix archive something-that-does-not-exist
then false; else true; fi
# This one must not be listed as missing.
guix build guile-bootstrap > "$archive"
guix archive --missing < "$archive"
test "`guix archive --missing < "$archive"`" = ""
# Two out of three should be listed as missing.
echo "$NIX_STORE_DIR/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo" >> "$archive"
echo "$NIX_STORE_DIR/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-bar" >> "$archive"
guix archive --missing < "$archive" > "$archive_alt"
echo "$NIX_STORE_DIR/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo" > "$archive"
echo "$NIX_STORE_DIR/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-bar" >> "$archive"
cmp "$archive" "$archive_alt"
# This is not a valid store file name, so an error.
echo something invalid > "$archive"
if guix archive --missing < "$archive"
then false; else true; fi
if echo foo | guix archive --authorize
then false; else true; fi

63
tests/guix-authenticate.sh Normal file
View File

@ -0,0 +1,63 @@
# GNU Guix --- Functional package management for GNU
# Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
#
# This file is part of GNU Guix.
#
# GNU Guix is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or (at
# your option) any later version.
#
# GNU Guix is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
#
# Test the 'guix authenticate' command-line utility.
#
guix authenticate --version
sig="t-signature-$$"
hash="t-hash-$$"
rm -f "$sig" "$hash"
trap 'rm -f "$sig" "$hash"' EXIT
# A hexadecimal string as long as a sha256 hash.
echo "2749f0ea9f26c6c7be746a9cff8fa4c2f2a02b000070dba78429e9a11f87c6eb" \
> "$hash"
guix authenticate rsautl -sign \
-inkey "$abs_top_srcdir/tests/signing-key.sec" \
-in "$hash" > "$sig"
test -f "$sig"
hash2="`guix authenticate rsautl -verify \
-inkey $abs_top_srcdir/tests/signing-key.pub \
-pubin -in $sig`"
test "$hash2" = `cat "$hash"`
# Detect corrupt signatures.
if guix authenticate rsautl -verify \
-inkey "$abs_top_srcdir/tests/signing-key.pub" \
-pubin -in /dev/null
then false
else true
fi
# Detect invalid signatures.
# The signature has (payload (data ... (hash sha256 #...#))). We proceed by
# modifying this hash.
sed -i "$sig" \
-e's|#[A-Z0-9]\{64\}#|#0000000000000000000000000000000000000000000000000000000000000000#|g'
if guix authenticate rsautl -verify \
-inkey "$abs_top_srcdir/tests/signing-key.pub" \
-pubin -in "$sig"
then false
else true
fi

9
tests/guix-package.sh
View File

@ -1,5 +1,5 @@
# GNU Guix --- Functional package management for GNU
# Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
# Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
# Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
#
# This file is part of GNU Guix.
@ -218,3 +218,10 @@ done
# Extraneous argument.
if guix package install foo-bar;
then false; else true; fi
# Make sure the "broken pipe" doesn't yield an error.
# Note: 'pipefail' is a Bash-specific option.
set -o pipefail || true
guix package -A g | head -1 2> "$HOME/err1"
guix package -I | head -1 2> "$HOME/err2"
test "`cat "$HOME/err1" "$HOME/err2"`" = ""

230
tests/pk-crypto.scm Normal file
View File

@ -0,0 +1,230 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (test-pk-crypto)
#:use-module (guix pk-crypto)
#:use-module (guix utils)
#:use-module (guix hash)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-64)
#:use-module (rnrs bytevectors)
#:use-module (rnrs io ports)
#:use-module (ice-9 match))
;; Test the (guix pk-crypto) module.
(define %key-pair
;; Key pair that was generated with:
;; (generate-key (string->canonical-sexp "(genkey (rsa (nbits 4:1024)))"))
;; which takes a bit of time.
"(key-data
(public-key
(rsa
(n #00C1F764069F54FFE93A126B02328903E984E4AE3AF6DF402B5B6B3907911B88C385F1BA76A002EC9DEA109A5228EF0E62EE31A06D1A5861CAB474F6C857AC66EB65A1905F25BBA1869579E73A3B7FED13AF5A1667326F88CDFC2FF24B03C14FD1384AA7E73CA89572880B606E3A974E15347963FC7B6378574936A47580DBCB45#)
(e #010001#)))
(private-key
(rsa
(n #00C1F764069F54FFE93A126B02328903E984E4AE3AF6DF402B5B6B3907911B88C385F1BA76A002EC9DEA109A5228EF0E62EE31A06D1A5861CAB474F6C857AC66EB65A1905F25BBA1869579E73A3B7FED13AF5A1667326F88CDFC2FF24B03C14FD1384AA7E73CA89572880B606E3A974E15347963FC7B6378574936A47580DBCB45#)
(e #010001#)
(d #58CAD84653D0046A8EC3F9AA82D9C829B145422109FC3F12DA01A694B92FA296E70D366FB166454D30E632CEE3A033B4C41781BA10325F69FCDC0250CA19C8EEB352FA085992494098DB133E682ED38A931701F0DED1A1E508F4341A4FB446A04F019427C7CB3C44F251EEA9D386100DA80F125E0FD5CE1B0DFEC6D21516EACD#)
(p #00D47F185147EC39393CCDA4E7323FFC20FC8B8073E2A54DD63BA392A66975E4204CA48572496A9DFD7522436B852C07472A5AB25B7706F7C14E6F33FBC420FF3B#)
(q #00E9AD22F158060BC9AE3601DA623AFC60FFF3058795802CA92371C00097335CF9A23D7782DE353C9DBA93D7BB99E6A24A411107605E722481C5C191F80D7EB77F#)
(u #59B45B95AE01A7A7370FAFDB08FE73A4793CE37F228961B09B1B1E7DDAD9F8D3E28F5C5E8B4B067E6B8E0BBF3F690B42991A79E46108DDCDA2514323A66964DE#))))")
(test-begin "pk-crypto")
(let ((sexps '("(foo bar)"
;; In Libgcrypt 1.5.3 the following integer is rendered as
;; binary, whereas in 1.6.0 it's rendered as is (hexadecimal.)
;;"#C0FFEE#"
"(genkey \n (rsa \n (nbits \"1024\")\n )\n )")))
(test-equal "string->canonical-sexp->string"
sexps
(let ((sexps (map string->canonical-sexp sexps)))
(and (every canonical-sexp? sexps)
(map (compose string-trim-both canonical-sexp->string) sexps)))))
(gc) ; stress test!
(let ((sexps `(("(foo bar)" foo -> "(foo bar)")
("(foo (bar (baz 3:123)))" baz -> "(baz \"123\")")
("(foo (bar 3:123))" baz -> #f))))
(test-equal "find-sexp-token"
(map (match-lambda
((_ _ '-> expected)
expected))
sexps)
(map (match-lambda
((input token '-> _)
(let ((sexp (find-sexp-token (string->canonical-sexp input) token)))
(and sexp
(string-trim-both (canonical-sexp->string sexp))))))
sexps)))
(gc)
(test-equal "canonical-sexp-length"
'(0 1 2 4 0 0)
(map (compose canonical-sexp-length string->canonical-sexp)
'("()" "(a)" "(a b)" "(a #616263# b #C001#)" "a" "#123456#")))
(test-equal "canonical-sexp-list?"
'(#t #f #t #f)
(map (compose canonical-sexp-list? string->canonical-sexp)
'("()" "\"abc\"" "(a b c)" "#123456#")))
(gc)
(test-equal "canonical-sexp-car + cdr"
'("(b \n (c xyz)\n )")
(let ((lst (string->canonical-sexp "(a (b (c xyz)))")))
(map (lambda (sexp)
(and sexp (string-trim-both (canonical-sexp->string sexp))))
;; Note: 'car' returns #f when the first element is an atom.
(list (canonical-sexp-car (canonical-sexp-cdr lst))))))
(gc)
(test-equal "canonical-sexp-nth"
'("(b pqr)" "(c \"456\")" "(d xyz)" #f #f)
(let ((lst (string->canonical-sexp "(a (b 3:pqr) (c 3:456) (d 3:xyz))")))
;; XXX: In Libgcrypt 1.5.3, (canonical-sexp-nth lst 0) returns LST, whereas in
;; 1.6.0 it returns #f.
(map (lambda (sexp)
(and sexp (string-trim-both (canonical-sexp->string sexp))))
(unfold (cut > <> 5)
(cut canonical-sexp-nth lst <>)
1+
1))))
(gc)
(test-equal "canonical-sexp-nth-data"
`(Name Otto Meier #f ,(base16-string->bytevector "123456") #f)
(let ((lst (string->canonical-sexp
"(Name Otto Meier (address Burgplatz) #123456#)")))
(unfold (cut > <> 5)
(cut canonical-sexp-nth-data lst <>)
1+
0)))
(gc)
;; XXX: The test below is typically too long as it needs to gather enough entropy.
;; (test-assert "generate-key"
;; (let ((key (generate-key (string->canonical-sexp
;; "(genkey (rsa (nbits 3:128)))"))))
;; (and (canonical-sexp? key)
;; (find-sexp-token key 'key-data)
;; (find-sexp-token key 'public-key)
;; (find-sexp-token key 'private-key))))
(test-assert "bytevector->hash-data->bytevector"
(let* ((bv (sha256 (string->utf8 "Hello, world.")))
(data (bytevector->hash-data bv "sha256")))
(and (canonical-sexp? data)
(let-values (((value algo) (hash-data->bytevector data)))
(and (string=? algo "sha256")
(bytevector=? value bv))))))
(test-assert "sign + verify"
(let* ((pair (string->canonical-sexp %key-pair))
(secret (find-sexp-token pair 'private-key))
(public (find-sexp-token pair 'public-key))
(data (bytevector->hash-data
(sha256 (string->utf8 "Hello, world."))))
(sig (sign data secret)))
(and (verify sig data public)
(not (verify sig
(bytevector->hash-data
(sha256 (string->utf8 "Hi!")))
public)))))
(gc)
(test-equal "canonical-sexp->sexp"
`((data
(flags pkcs1)
(hash sha256
,(base16-string->bytevector
"2749f0ea9f26c6c7be746a9cff8fa4c2f2a02b000070dba78429e9a11f87c6eb")))
(public-key
(rsa
(n ,(base16-string->bytevector
(string-downcase
"00C1F764069F54FFE93A126B02328903E984E4AE3AF6DF402B5B6B3907911B88C385F1BA76A002EC9DEA109A5228EF0E62EE31A06D1A5861CAB474F6C857AC66EB65A1905F25BBA1869579E73A3B7FED13AF5A1667326F88CDFC2FF24B03C14FD1384AA7E73CA89572880B606E3A974E15347963FC7B6378574936A47580DBCB45")))
(e ,(base16-string->bytevector
"010001")))))
(list (canonical-sexp->sexp
(string->canonical-sexp
"(data
(flags pkcs1)
(hash \"sha256\"
#2749f0ea9f26c6c7be746a9cff8fa4c2f2a02b000070dba78429e9a11f87c6eb#))"))
(canonical-sexp->sexp
(find-sexp-token (string->canonical-sexp %key-pair)
'public-key))))
(let ((lst
`((data
(flags pkcs1)
(hash sha256
,(base16-string->bytevector
"2749f0ea9f26c6c7be746a9cff8fa4c2f2a02b000070dba78429e9a11f87c6eb")))
(public-key
(rsa
(n ,(base16-string->bytevector
(string-downcase
"00C1F764069F54FFE93A126B02328903E984E4AE3AF6DF402B5B6B3907911B88C385F1BA76A002EC9DEA109A5228EF0E62EE31A06D1A5861CAB474F6C857AC66EB65A1905F25BBA1869579E73A3B7FED13AF5A1667326F88CDFC2FF24B03C14FD1384AA7E73CA89572880B606E3A974E15347963FC7B6378574936A47580DBCB45")))
(e ,(base16-string->bytevector
"010001"))))
,(base16-string->bytevector
"2749f0ea9f26c6c7be746a9cff8fa4c2f2a02b000070dba78429e9a11f87c6eb"))))
(test-equal "sexp->canonical-sexp->sexp"
lst
(map (compose canonical-sexp->sexp sexp->canonical-sexp)
lst)))
(let ((sexp `(signature
(public-key
(rsa
(n ,(make-bytevector 1024 1))
(e ,(base16-string->bytevector "010001")))))))
(test-equal "https://bugs.g10code.com/gnupg/issue1594"
;; The gcrypt bug above was primarily affecting our uses in
;; 'canonical-sexp->sexp', typically when applied to a signature sexp (in
;; 'guix authenticate -verify') with a "big" RSA key, such as 4096 bits.
sexp
(canonical-sexp->sexp (sexp->canonical-sexp sexp))))
(test-end)
(exit (= (test-runner-fail-count (test-runner-current)) 0))

51
tests/pki.scm Normal file
View File

@ -0,0 +1,51 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (test-pki)
#:use-module (guix pki)
#:use-module (guix pk-crypto)
#:use-module (rnrs io ports)
#:use-module (srfi srfi-64))
;; Test the (guix pki) module.
(define %public-key
(call-with-input-file %public-key-file
(compose string->canonical-sexp
get-string-all)))
(test-begin "pki")
(test-assert "current-acl"
(not (not (member (canonical-sexp->sexp %public-key)
(map canonical-sexp->sexp
(acl->public-keys (current-acl)))))))
(test-assert "authorized-key? public-key current-acl"
(authorized-key? %public-key))
(test-assert "authorized-key? public-key empty-acl"
(not (authorized-key? %public-key (public-keys->acl '()))))
(test-assert "authorized-key? public-key singleton"
(authorized-key? %public-key (public-keys->acl (list %public-key))))
(test-end)
(exit (= (test-runner-fail-count (test-runner-current)) 0))

4
tests/signing-key.pub Normal file
View File

@ -0,0 +1,4 @@
(public-key
(rsa
(n #00C1F764069F54FFE93A126B02328903E984E4AE3AF6DF402B5B6B3907911B88C385F1BA76A002EC9DEA109A5228EF0E62EE31A06D1A5861CAB474F6C857AC66EB65A1905F25BBA1869579E73A3B7FED13AF5A1667326F88CDFC2FF24B03C14FD1384AA7E73CA89572880B606E3A974E15347963FC7B6378574936A47580DBCB45#)
(e #010001#)))

8
tests/signing-key.sec Normal file
View File

@ -0,0 +1,8 @@
(private-key
(rsa
(n #00C1F764069F54FFE93A126B02328903E984E4AE3AF6DF402B5B6B3907911B88C385F1BA76A002EC9DEA109A5228EF0E62EE31A06D1A5861CAB474F6C857AC66EB65A1905F25BBA1869579E73A3B7FED13AF5A1667326F88CDFC2FF24B03C14FD1384AA7E73CA89572880B606E3A974E15347963FC7B6378574936A47580DBCB45#)
(e #010001#)
(d #58CAD84653D0046A8EC3F9AA82D9C829B145422109FC3F12DA01A694B92FA296E70D366FB166454D30E632CEE3A033B4C41781BA10325F69FCDC0250CA19C8EEB352FA085992494098DB133E682ED38A931701F0DED1A1E508F4341A4FB446A04F019427C7CB3C44F251EEA9D386100DA80F125E0FD5CE1B0DFEC6D21516EACD#)
(p #00D47F185147EC39393CCDA4E7323FFC20FC8B8073E2A54DD63BA392A66975E4204CA48572496A9DFD7522436B852C07472A5AB25B7706F7C14E6F33FBC420FF3B#)
(q #00E9AD22F158060BC9AE3601DA623AFC60FFF3058795802CA92371C00097335CF9A23D7782DE353C9DBA93D7BB99E6A24A411107605E722481C5C191F80D7EB77F#)
(u #59B45B95AE01A7A7370FAFDB08FE73A4793CE37F228961B09B1B1E7DDAD9F8D3E28F5C5E8B4B067E6B8E0BBF3F690B42991A79E46108DDCDA2514323A66964DE#)))

45
tests/store.scm
View File

@ -28,10 +28,12 @@
#:use-module (gnu packages)
#:use-module (gnu packages bootstrap)
#:use-module (ice-9 match)
#:use-module (rnrs bytevectors)
#:use-module (rnrs io ports)
#:use-module (web uri)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-64))
@ -344,6 +346,49 @@ Deriver: ~a~%"
(build-derivations s (list d))
#f))))
(test-assert "export/import several paths"
(let* ((texts (unfold (cut >= <> 10)
(lambda _ (random-text))
1+
0))
(files (map (cut add-text-to-store %store "text" <>) texts))
(dump (call-with-bytevector-output-port
(cut export-paths %store files <>))))
(delete-paths %store files)
(and (every (negate file-exists?) files)
(let* ((source (open-bytevector-input-port dump))
(imported (import-paths %store source)))
(and (equal? imported files)
(every file-exists? files)
(equal? texts
(map (lambda (file)
(call-with-input-file file
get-string-all))
files)))))))
(test-assert "import corrupt path"
(let* ((text (random-text))
(file (add-text-to-store %store "text" text))
(dump (call-with-bytevector-output-port
(cut export-paths %store (list file) <>))))
(delete-paths %store (list file))
;; Flip a bit in the stream's payload.
(let* ((index (quotient (bytevector-length dump) 4))
(byte (bytevector-u8-ref dump index)))
(bytevector-u8-set! dump index (logxor #xff byte)))
(and (not (file-exists? file))
(guard (c ((nix-protocol-error? c)
(pk 'c c)
(and (not (zero? (nix-protocol-error-status c)))
(string-contains (nix-protocol-error-message c)
"corrupt"))))
(let* ((source (open-bytevector-input-port dump))
(imported (import-paths %store source)))
(pk 'corrupt-imported imported)
#f)))))
(test-end "store")