diff options
| author | Ludovic Courtès <ludo@gnu.org> | 2014-01-08 22:06:54 +0100 |
|---|---|---|
| committer | Ludovic Courtès <ludo@gnu.org> | 2014-01-08 22:06:54 +0100 |
| commit | 2f265602ff23e41f75932aa568fe62e149e3cb9d (patch) | |
| tree | 3ff7d0b4be81246a4dfd3df414e163d8cbdc4990 | |
| parent | aa6b0d6bf01aba60c6b5524e4422e7a4cebf01e4 (diff) | |
| parent | 1d6816f98ca1746f0b627a6dee9c0adbbf7533c4 (diff) | |
| download | patches-2f265602ff23e41f75932aa568fe62e149e3cb9d.tar patches-2f265602ff23e41f75932aa568fe62e149e3cb9d.tar.gz | |
Merge branch 'master' into core-updates
62 files changed, 2510 insertions, 430 deletions
diff --git a/.dir-locals.el b/.dir-locals.el index bb4e964dd5..87cdaae807 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -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)) diff --git a/.gitignore b/.gitignore index a8a5cad74c..09a593e9fa 100644 --- a/.gitignore +++ b/.gitignore @@ -84,3 +84,4 @@ GPATH GRTAGS GTAGS /nix-setuid-helper +/nix/scripts/guix-authenticate diff --git a/Makefile.am b/Makefile.am index eb278a76e9..6d6aba059b 100644 --- a/Makefile.am +++ b/Makefile.am @@ -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 \ @@ -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) @@ -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> @@ -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 + +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 package descriptions with GSRC and/or the [[http://directory.fsf.org][FSD]] +* 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 diff --git a/config-daemon.ac b/config-daemon.ac index 5db08d099d..0717141198 100644 --- a/config-daemon.ac +++ b/config-daemon.ac @@ -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"]) diff --git a/configure.ac b/configure.ac index 07f8539504..799b3e8152 100644 --- a/configure.ac +++ b/configure.ac @@ -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";; @@ -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 \ diff --git a/doc/guix.texi b/doc/guix.texi index fcffa5a22b..93d1c2be3b 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -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 @@ -407,9 +416,10 @@ management tools it provides. @menu * Features:: How Guix will make your life brighter. * Invoking guix package:: Package installation, removal, etc. -* Packages with Multiple Outputs:: Single source package, multiple outputs. +* 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. diff --git a/gnu-system.am b/gnu-system.am index d2b9bee25c..fbf61d6ec1 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -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 \ diff --git a/gnu/packages.scm b/gnu/packages.scm index e9f2540b91..8365a00051 100644 --- a/gnu/packages.scm +++ b/gnu/packages.scm @@ -33,6 +33,7 @@ %bootstrap-binaries-path fold-packages find-packages-by-name + find-best-packages-by-name find-newest-available-packages)) ;;; Commentary: @@ -148,24 +149,36 @@ then only return packages whose version is equal to VERSION." result)) '())) -(define (find-newest-available-packages) - "Return a vhash keyed by package names, and with +(define find-newest-available-packages + (memoize + (lambda () + "Return a vhash keyed by package names, and with associated values of the form (newest-version newest-package ...) where the preferred package is listed first." - ;; FIXME: Currently, the preferred package is whichever one - ;; was found last by 'fold-packages'. Find a better solution. - (fold-packages (lambda (p r) - (let ((name (package-name p)) - (version (package-version p))) - (match (vhash-assoc name r) - ((_ newest-so-far . pkgs) - (case (version-compare version newest-so-far) - ((>) (vhash-cons name `(,version ,p) r)) - ((=) (vhash-cons name `(,version ,p ,@pkgs) r)) - ((<) r))) - (#f (vhash-cons name `(,version ,p) r))))) - vlist-null)) + ;; FIXME: Currently, the preferred package is whichever one + ;; was found last by 'fold-packages'. Find a better solution. + (fold-packages (lambda (p r) + (let ((name (package-name p)) + (version (package-version p))) + (match (vhash-assoc name r) + ((_ newest-so-far . pkgs) + (case (version-compare version newest-so-far) + ((>) (vhash-cons name `(,version ,p) r)) + ((=) (vhash-cons name `(,version ,p ,@pkgs) r)) + ((<) r))) + (#f (vhash-cons name `(,version ,p) r))))) + 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 '())))) diff --git a/gnu/packages/autotools.scm b/gnu/packages/autotools.scm index d37842c4ce..c2e4637ac0 100644 --- a/gnu/packages/autotools.scm +++ b/gnu/packages/autotools.scm @@ -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) diff --git a/gnu/packages/cdrom.scm b/gnu/packages/cdrom.scm index e54cce55fd..195de8ce52 100644 --- a/gnu/packages/cdrom.scm +++ b/gnu/packages/cdrom.scm @@ -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) diff --git a/gnu/packages/games.scm b/gnu/packages/games.scm new file mode 100644 index 0000000000..0f5ae4174d --- /dev/null +++ b/gnu/packages/games.scm @@ -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+))) diff --git a/gnu/packages/gdbm.scm b/gnu/packages/gdbm.scm index a43db9243e..62d02001c8 100644 --- a/gnu/packages/gdbm.scm +++ b/gnu/packages/gdbm.scm @@ -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/") diff --git a/gnu/packages/gl.scm b/gnu/packages/gl.scm index f54d6899ae..ee8aed9284 100644 --- a/gnu/packages/gl.scm +++ b/gnu/packages/gl.scm @@ -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))) diff --git a/gnu/packages/gnome.scm b/gnu/packages/gnome.scm index 609310efa5..90683f3635 100644 --- a/gnu/packages/gnome.scm +++ b/gnu/packages/gnome.scm @@ -21,6 +21,7 @@ #:use-module (guix packages) #:use-module (guix download) #:use-module (guix build-system gnu) + #:use-module (gnu packages) #:use-module (gnu packages 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+))) diff --git a/gnu/packages/gnunet.scm b/gnu/packages/gnunet.scm index 63bbf08b56..df5b1e337c 100644 --- a/gnu/packages/gnunet.scm +++ b/gnu/packages/gnunet.scm @@ -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. diff --git a/gnu/packages/gnupg.scm b/gnu/packages/gnupg.scm index be13eb0ba0..c3f717e60e 100644 --- a/gnu/packages/gnupg.scm +++ b/gnu/packages/gnupg.scm @@ -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") diff --git a/gnu/packages/gnuzilla.scm b/gnu/packages/gnuzilla.scm index c3f464c15e..c2a1801c16 100644 --- a/gnu/packages/gnuzilla.scm +++ b/gnu/packages/gnuzilla.scm @@ -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)) diff --git a/gnu/packages/iso-codes.scm b/gnu/packages/iso-codes.scm index e1424b81ef..be0b746796 100644 --- a/gnu/packages/iso-codes.scm +++ b/gnu/packages/iso-codes.scm @@ -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) diff --git a/gnu/packages/lsh.scm b/gnu/packages/lsh.scm index ac01a878bc..1c823492c5 100644 --- a/gnu/packages/lsh.scm +++ b/gnu/packages/lsh.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -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 - (method url-fetch) - (uri (string-append "mirror://gnu/lsh/lsh-" - version ".tar.gz")) - (sha256 - (base32 - "1qqjy9zfzgny0rkb27c8c7dfsylvb6n0ld8h3an2r83pmaqr9gwb")))) + (source (origin + (method url-fetch) + (uri (string-append "mirror://gnu/lsh/lsh-" + version ".tar.gz")) + (sha256 + (base32 + "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 _ - ;; Tests rely on $USER being set. - (setenv "USER" "guix") + '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")))) - (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")))) + ;; Tests rely on $USER being set. + (setenv "USER" "guix")) %standard-phases))) (home-page "http://www.lysator.liu.se/~nisse/lsh/") (synopsis "GNU implementation of the Secure Shell (ssh) protocols") diff --git a/gnu/packages/nettle.scm b/gnu/packages/nettle.scm index 4e9b3dd7b7..96407837b4 100644 --- a/gnu/packages/nettle.scm +++ b/gnu/packages/nettle.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -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") diff --git a/gnu/packages/parallel.scm b/gnu/packages/parallel.scm index 83b45cc15f..9ce24a3cbf 100644 --- a/gnu/packages/parallel.scm +++ b/gnu/packages/parallel.scm @@ -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/") diff --git a/gnu/packages/patches/gtkglext-disable-disable-deprecated.patch b/gnu/packages/patches/gtkglext-disable-disable-deprecated.patch new file mode 100644 index 0000000000..8f0c23c97f --- /dev/null +++ b/gnu/packages/patches/gtkglext-disable-disable-deprecated.patch @@ -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 = \ diff --git a/gnu/packages/patches/gtkglext-remove-pangox-dependency.patch b/gnu/packages/patches/gtkglext-remove-pangox-dependency.patch new file mode 100644 index 0000000000..4f03785322 --- /dev/null +++ b/gnu/packages/patches/gtkglext-remove-pangox-dependency.patch @@ -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@ diff --git a/gnu/packages/patches/pulseaudio-volume-test.patch b/gnu/packages/patches/pulseaudio-volume-test.patch new file mode 100644 index 0000000000..2cfa0cd6ca --- /dev/null +++ b/gnu/packages/patches/pulseaudio-volume-test.patch @@ -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 diff --git a/gnu/packages/pulseaudio.scm b/gnu/packages/pulseaudio.scm index a2e8217422..91bbe2d77a 100644 --- a/gnu/packages/pulseaudio.scm +++ b/gnu/packages/pulseaudio.scm @@ -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) diff --git a/gnu/packages/python.scm b/gnu/packages/python.scm index faf2c9d527..b5070e7fda 100644 --- a/gnu/packages/python.scm +++ b/gnu/packages/python.scm @@ -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") diff --git a/gnu/packages/qemu.scm b/gnu/packages/qemu.scm index 0d7923ba0f..4212d74821 100644 --- a/gnu/packages/qemu.scm +++ b/gnu/packages/qemu.scm @@ -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)) diff --git a/gnu/packages/qt.scm b/gnu/packages/qt.scm index e40ae81aaa..f22fbe6f9e 100644 --- a/gnu/packages/qt.scm +++ b/gnu/packages/qt.scm @@ -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 diff --git a/gnu/packages/sdl.scm b/gnu/packages/sdl.scm index fa1b5da4eb..86b403503b 100644 --- a/gnu/packages/sdl.scm +++ b/gnu/packages/sdl.scm @@ -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 diff --git a/gnu/packages/shishi.scm b/gnu/packages/shishi.scm index 2f5fa8a37c..0523a4eef5 100644 --- a/gnu/packages/shishi.scm +++ b/gnu/packages/shishi.scm @@ -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") diff --git a/gnu/packages/ssh.scm b/gnu/packages/ssh.scm index 76d51c44c6..2197388902 100644 --- a/gnu/packages/ssh.scm +++ b/gnu/packages/ssh.scm @@ -36,20 +36,20 @@ (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" - ;; Leave a valid RUNPATH upon install. - "-DCMAKE_SKIP_BUILD_RPATH=ON") + ;; Leave a valid RUNPATH upon install. + "-DCMAKE_SKIP_BUILD_RPATH=ON") ;; TODO: Add 'CMockery' and '-DWITH_TESTING=ON' for the test suite. #:tests? #f @@ -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 diff --git a/gnu/packages/vim.scm b/gnu/packages/vim.scm index a80f50a4a6..0b532ae4e2 100644 --- a/gnu/packages/vim.scm +++ b/gnu/packages/vim.scm @@ -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" diff --git a/gnu/packages/xorg.scm b/gnu/packages/xorg.scm index acc9fe61eb..dfdd82c8b8 100644 --- a/gnu/packages/xorg.scm +++ b/gnu/packages/xorg.scm @@ -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 diff --git a/guix/config.scm.in b/guix/config.scm.in index 772ea8c289..3a5c50e00a 100644 --- a/guix/config.scm.in +++ b/guix/config.scm.in @@ -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@") diff --git a/guix/pk-crypto.scm b/guix/pk-crypto.scm new file mode 100644 index 0000000000..50f709418c --- /dev/null +++ b/guix/pk-crypto.scm @@ -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 diff --git a/guix/pki.scm b/guix/pki.scm new file mode 100644 index 0000000000..5e4dbadd35 --- /dev/null +++ b/guix/pki.scm @@ -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 diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm new file mode 100644 index 0000000000..32690c6b45 --- /dev/null +++ b/guix/scripts/archive.scm @@ -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~%"))))))))))) diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm new file mode 100644 index 0000000000..c7a14f7a8b --- /dev/null +++ b/guix/scripts/authenticate.scm @@ -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 diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index dd9a9b8127..7cb3710853 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 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))) @@ -91,6 +134,8 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (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")) (display (_ " @@ -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,146 +267,66 @@ 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)) - (roots (filter-map (match-lambda - (('gc-root . root) root) - (_ #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 - #:use-substitutes? (assoc-ref opts 'substitutes?) - #:dry-run? (assoc-ref opts 'dry-run?))) + (unless (assoc-ref opts 'log-file?) + (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) - #: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?) - #:max-silent-time (assoc-ref opts 'max-silent-time) - #:verbosity (assoc-ref opts 'verbosity)) + ;; TODO: Add more options. + (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))) - (if log - (format #t "~a~%" log) - (leave (_ "no build log for '~a'~%") - file)))) - (delete-duplicates - (append (map derivation-file-name drv) - (filter-map (match-lambda - (('argument - . (? store-path? file)) - file) - (_ #f)) - opts))))) - ((assoc-ref opts 'derivations-only?) - (format #t "~{~a~%~}" (map derivation-file-name drv)) - (for-each (cut register-root <> <>) - (map (compose list derivation-file-name) drv) - roots)) - ((not (assoc-ref opts 'dry-run?)) - (and (build-derivations (%store) drv) - (for-each (lambda (d) - (format #t "~{~a~%~}" - (map (match-lambda - ((out-name . out) - (derivation->output-path - d out-name))) - (derivation-outputs d)))) - drv) - (for-each (cut register-root <> <>) - (map (lambda (drv) - (map cdr - (derivation->output-paths drv))) - drv) - roots)))))))))) + (cond ((assoc-ref opts 'log-file?) + (for-each (lambda (file) + (let ((log (log-file store file))) + (if log + (format #t "~a~%" log) + (leave (_ "no build log for '~a'~%") + file)))) + (delete-duplicates + (append (map derivation-file-name drv) + (filter-map (match-lambda + (('argument + . (? store-path? file)) + file) + (_ #f)) + opts))))) + ((assoc-ref opts 'derivations-only?) + (format #t "~{~a~%~}" (map derivation-file-name drv)) + (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) + (for-each (lambda (d) + (format #t "~{~a~%~}" + (map (match-lambda + ((out-name . out) + (derivation->output-path + d out-name))) + (derivation-outputs d)))) + drv) + (for-each (cut register-root store <> <>) + (map (lambda (drv) + (map cdr + (derivation->output-paths drv))) + drv) + roots)))))))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 49fa457a9c..04393abc9a 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 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))) - (if (equal? numbers '(0)) - (exit 0) - (for-each list-generation numbers)))) + (leave-on-EPIPE + (if (equal? numbers '(0)) + (exit 0) + (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,15 +994,16 @@ more information.~%")) (let* ((regexp (and regexp (make-regexp regexp))) (manifest (profile-manifest profile)) (installed (manifest-entries manifest))) - (for-each (match-lambda - (($ <manifest-entry> name version output path _) - (when (or (not regexp) - (regexp-exec regexp name)) - (format #t "~a\t~a\t~a\t~a~%" - name (or version "?") output path)))) - - ;; Show most recently installed packages last. - (reverse installed)) + (leave-on-EPIPE + (for-each (match-lambda + (($ <manifest-entry> name version output path _) + (when (or (not regexp) + (regexp-exec regexp name)) + (format #t "~a\t~a\t~a\t~a~%" + name (or version "?") output path)))) + + ;; Show most recently installed packages last. + (reverse installed))) #t)) (('list-available regexp) @@ -1010,16 +1017,17 @@ more information.~%")) r) (cons p r)))) '()))) - (for-each (lambda (p) - (format #t "~a\t~a\t~a\t~a~%" - (package-name p) - (package-version p) - (string-join (package-outputs p) ",") - (location->string (package-location p)))) - (sort available - (lambda (p1 p2) - (string<? (package-name p1) - (package-name p2))))) + (leave-on-EPIPE + (for-each (lambda (p) + (format #t "~a\t~a\t~a\t~a~%" + (package-name p) + (package-version p) + (string-join (package-outputs p) ",") + (location->string (package-location p)))) + (sort available + (lambda (p1 p2) + (string<? (package-name p1) + (package-name p2)))))) #t)) (('search regexp) diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index 0da29d435b..901b3fb064 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -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: diff --git a/guix/store.scm b/guix/store.scm index 08b0671b29..1012480b39 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -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/nix/drvs/" - (string-take base 2) "/" - (string-drop base 2) ".bz2"))) - (and (file-exists? log) log))) + (let* ((base (basename file)) + (log (string-append (dirname %state-directory) ; XXX + "/log/nix/drvs/" + (string-take base 2) "/" + (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 ...) diff --git a/guix/utils.scm b/guix/utils.scm index b730340eda..04a74ee29a 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -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) diff --git a/nix/libutil/gcrypt-hash.cc b/nix/libutil/gcrypt-hash.cc index 553f633b93..c4ae7bfcc2 100644 --- a/nix/libutil/gcrypt-hash.cc +++ b/nix/libutil/gcrypt-hash.cc @@ -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; } } diff --git a/nix/libutil/gcrypt-hash.hh b/nix/libutil/gcrypt-hash.hh index d93a6eb881..11f061159f 100644 --- a/nix/libutil/gcrypt-hash.hh +++ b/nix/libutil/gcrypt-hash.hh @@ -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); - } diff --git a/nix/nix-daemon/guix-daemon.cc b/nix/nix-daemon/guix-daemon.cc index 4f9fa4c525..cf87e39354 100644 --- a/nix/nix-daemon/guix-daemon.cc +++ b/nix/nix-daemon/guix-daemon.cc @@ -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; diff --git a/nix/scripts/guix-authenticate.in b/nix/scripts/guix-authenticate.in new file mode 100644 index 0000000000..5ce57915f0 --- /dev/null +++ b/nix/scripts/guix-authenticate.in @@ -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 diff --git a/nix/sync-with-upstream b/nix/sync-with-upstream index 535763d602..720fae132e 100755 --- a/nix/sync-with-upstream +++ b/nix/sync-with-upstream @@ -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' diff --git a/po/POTFILES.in b/po/POTFILES.in index 0e30bb0880..beefdc901b 100644 --- a/po/POTFILES.in +++ b/po/POTFILES.in @@ -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 diff --git a/test-env.in b/test-env.in index 9224a80537..df73ecdc7a 100644 --- a/test-env.in +++ b/test-env.in @@ -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" diff --git a/tests/guix-archive.sh b/tests/guix-archive.sh new file mode 100644 index 0000000000..0de7395145 --- /dev/null +++ b/tests/guix-archive.sh @@ -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 diff --git a/tests/guix-authenticate.sh b/tests/guix-authenticate.sh new file mode 100644 index 0000000000..aa6f9e9f01 --- /dev/null +++ b/tests/guix-authenticate.sh @@ -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 diff --git a/tests/guix-package.sh b/tests/guix-package.sh index 47a2d06cb3..b79c4951d8 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -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"`" = "" diff --git a/tests/pk-crypto.scm b/tests/pk-crypto.scm new file mode 100644 index 0000000000..6774dd4157 --- /dev/null +++ b/tests/pk-crypto.scm @@ -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)) diff --git a/tests/pki.scm b/tests/pki.scm new file mode 100644 index 0000000000..04d5a5311b --- /dev/null +++ b/tests/pki.scm @@ -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)) diff --git a/tests/signing-key.pub b/tests/signing-key.pub new file mode 100644 index 0000000000..092424a15d --- /dev/null +++ b/tests/signing-key.pub @@ -0,0 +1,4 @@ +(public-key + (rsa + (n #00C1F764069F54FFE93A126B02328903E984E4AE3AF6DF402B5B6B3907911B88C385F1BA76A002EC9DEA109A5228EF0E62EE31A06D1A5861CAB474F6C857AC66EB65A1905F25BBA1869579E73A3B7FED13AF5A1667326F88CDFC2FF24B03C14FD1384AA7E73CA89572880B606E3A974E15347963FC7B6378574936A47580DBCB45#) + (e #010001#))) diff --git a/tests/signing-key.sec b/tests/signing-key.sec new file mode 100644 index 0000000000..558e189102 --- /dev/null +++ b/tests/signing-key.sec @@ -0,0 +1,8 @@ +(private-key + (rsa + (n #00C1F764069F54FFE93A126B02328903E984E4AE3AF6DF402B5B6B3907911B88C385F1BA76A002EC9DEA109A5228EF0E62EE31A06D1A5861CAB474F6C857AC66EB65A1905F25BBA1869579E73A3B7FED13AF5A1667326F88CDFC2FF24B03C14FD1384AA7E73CA89572880B606E3A974E15347963FC7B6378574936A47580DBCB45#) + (e #010001#) + (d #58CAD84653D0046A8EC3F9AA82D9C829B145422109FC3F12DA01A694B92FA296E70D366FB166454D30E632CEE3A033B4C41781BA10325F69FCDC0250CA19C8EEB352FA085992494098DB133E682ED38A931701F0DED1A1E508F4341A4FB446A04F019427C7CB3C44F251EEA9D386100DA80F125E0FD5CE1B0DFEC6D21516EACD#) + (p #00D47F185147EC39393CCDA4E7323FFC20FC8B8073E2A54DD63BA392A66975E4204CA48572496A9DFD7522436B852C07472A5AB25B7706F7C14E6F33FBC420FF3B#) + (q #00E9AD22F158060BC9AE3601DA623AFC60FFF3058795802CA92371C00097335CF9A23D7782DE353C9DBA93D7BB99E6A24A411107605E722481C5C191F80D7EB77F#) + (u #59B45B95AE01A7A7370FAFDB08FE73A4793CE37F228961B09B1B1E7DDAD9F8D3E28F5C5E8B4B067E6B8E0BBF3F690B42991A79E46108DDCDA2514323A66964DE#))) diff --git a/tests/store.scm b/tests/store.scm index 281b923c28..4bd739e7f6 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -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") |