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

Merge branch 'master' into python-build-system

master
Hartmut Goebel 2016-11-29 18:47:16 +01:00
parent 2cb64f3b1b 683c5ab70a
commit 3bf4280659
No known key found for this signature in database
GPG Key ID: 634A8DFFD3F631DF
68 changed files with 4999 additions and 1248 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
.mailmap
View File

@ -30,10 +30,11 @@ Ludovic Courtès <ludo@gnu.org> <ludovic.courtes@inria.fr>
Mathieu Lirzin <mthl@gnu.org> <mthl@openmailbox.org>
Mathieu Lirzin <mthl@gnu.org> <mathieu.lirzin@openmailbox.org>
Nikita Karetnikov <nikita@karetnikov.org> <nikita.karetnikov@gmail.com>
ng0 <ng0@we.make.ritual.n0.is> <ngillmann@runbox.com>
ng0 <ng0@we.make.ritual.n0.is> <niasterisk@grrlz.net>
ng0 <ng0@we.make.ritual.n0.is> <ng@niasterisk.space>
ng0 <ng0@we.make.ritual.n0.is> <ng0@libertad.pw>
ng0 <ng0@libertad.pw> <ng0@we.make.ritual.n0.is>
ng0 <ng0@libertad.pw> <ngillmann@runbox.com>
ng0 <ng0@libertad.pw> <niasterisk@grrlz.net>
ng0 <ng0@libertad.pw> <ng@niasterisk.space>
ng0 <ng0@libertad.pw>
Pjotr Prins <pjotr.public01@thebird.nl>
Pjotr Prins <pjotr.public01@thebird.nl> <pjotr.public12@thebird.nl>
Raimon Grau <raimonster@gmail.com> <raimon@3scale.net>

19
build-aux/build-self.scm
View File

@ -61,6 +61,8 @@
(define guile-json
(first (find-best-packages-by-name "guile-json" #f)))
(define guile-ssh
(first (find-best-packages-by-name "guile-ssh" #f)))
;; The actual build procedure.
@ -103,8 +105,21 @@ files."
(use-modules (guix build pull))
(let ((json (string-append #$guile-json "/share/guile/site/2.0")))
(set! %load-path (cons json %load-path))
(set! %load-compiled-path (cons json %load-compiled-path)))
(set! %load-path
(cons* json
(string-append #$guile-ssh "/share/guile/site/2.0")
%load-path))
(set! %load-compiled-path
(cons* json
(string-append #$guile-ssh "/lib/guile/2.0/site-ccache")
%load-compiled-path)))
;; XXX: The 'guile-ssh' package prior to Guix commit 92b7258 was
;; broken: libguile-ssh could not be found. Work around that.
;; FIXME: We want Guile-SSH 0.10.2 or later anyway.
#$(if (string-prefix? "0.9." (package-version guile-ssh))
#~(setenv "LTDL_LIBRARY_PATH" (string-append #$guile-ssh "/lib"))
#t)
(build-guix #$output #$source

18
config-daemon.ac
View File

@ -128,12 +128,20 @@ if test "x$guix_build_daemon" = "xyes"; then
dnl 'restore-file-set', which requires unbuffered custom binary input
dnl ports from Guile >= 2.0.10.)
GUIX_CHECK_UNBUFFERED_CBIP
guix_build_daemon_offload="$ac_cv_guix_cbips_support_setvbuf"
if test "x$guix_build_daemon_offload" = "xyes"; then
AC_DEFINE([HAVE_DAEMON_OFFLOAD_HOOK], [1],
[Define if the daemon's 'offload' build hook is being built.])
fi
dnl Check for Guile-SSH, which is required by 'guix offload'.
GUIX_CHECK_GUILE_SSH
case "x$ac_cv_guix_cbips_support_setvbuf$guix_cv_have_recent_guile_ssh" in
xyesyes)
guix_build_daemon_offload="yes"
AC_DEFINE([HAVE_DAEMON_OFFLOAD_HOOK], [1],
[Define if the daemon's 'offload' build hook is being built (requires Guile-SSH).])
;;
*)
guix_build_daemon_offload="no"
;;
esac
dnl Temporary directory used to store the daemon's data.
GUIX_TEST_ROOT_DIRECTORY

184
doc/guix.texi
View File

@ -566,6 +566,12 @@ allow you to use the @command{guix import pypi} command (@pxref{Invoking
guix import}). It is of
interest primarily for developers and not for casual users.
@item
@c Note: We need at least 0.10.2 for 'channel-send-eof'.
Support for build offloading (@pxref{Daemon Offload Setup}) depends on
@uref{https://github.com/artyom-poptsov/guile-ssh, Guile-SSH},
version 0.10.2 or later.
@item
When @url{http://zlib.net, zlib} is available, @command{guix publish}
can compress build byproducts (@pxref{Invoking guix publish}).
@ -814,9 +820,11 @@ available on the system---making it much harder to view them as
@cindex offloading
@cindex build hook
When desired, the build daemon can @dfn{offload}
derivation builds to other machines
running Guix, using the @code{offload} @dfn{build hook}. When that
When desired, the build daemon can @dfn{offload} derivation builds to
other machines running Guix, using the @code{offload} @dfn{build
hook}@footnote{This feature is available only when
@uref{https://github.com/artyom-poptsov/guile-ssh, Guile-SSH} is
present.}. When that
feature is enabled, a list of user-specified build machines is read from
@file{/etc/guix/machines.scm}; every time a build is requested, for
instance via @code{guix build}, the daemon attempts to offload it to one
@ -832,16 +840,18 @@ The @file{/etc/guix/machines.scm} file typically looks like this:
(list (build-machine
(name "eightysix.example.org")
(system "x86_64-linux")
(host-key "ssh-ed25519 AAAAC3Nza@dots{}")
(user "bob")
(speed 2.)) ; incredibly fast!
(speed 2.)) ;incredibly fast!
(build-machine
(name "meeps.example.org")
(system "mips64el-linux")
(host-key "ssh-rsa AAAAB3Nza@dots{}")
(user "alice")
(private-key
(string-append (getenv "HOME")
"/.lsh/identity-for-guix"))))
"/.ssh/identity-for-guix"))))
@end example
@noindent
@ -875,31 +885,54 @@ The user account to use when connecting to the remote machine over SSH.
Note that the SSH key pair must @emph{not} be passphrase-protected, to
allow non-interactive logins.
@item host-key
This must be the machine's SSH @dfn{public host key} in OpenSSH format.
This is used to authenticate the machine when we connect to it. It is a
long string that looks like this:
@example
ssh-ed25519 AAAAC3NzaC@dots{}mde+UhL hint@@example.org
@end example
If the machine is running the OpenSSH daemon, @command{sshd}, the host
key can be found in a file such as
@file{/etc/ssh/ssh_host_ed25519_key.pub}.
If the machine is running the SSH daemon of GNU@tie{}lsh,
@command{lshd}, the host key is in @file{/etc/lsh/host-key.pub} or a
similar file. It can be converted to the OpenSSH format using
@command{lsh-export-key} (@pxref{Converting keys,,, lsh, LSH Manual}):
@example
$ lsh-export-key --openssh < /etc/lsh/host-key.pub
ssh-rsa AAAAB3NzaC1yc2EAAAAEOp8FoQAAAQEAs1eB46LV@dots{}
@end example
@end table
A number of optional fields may be specified:
@table @code
@table @asis
@item port
Port number of SSH server on the machine (default: 22).
@item @code{port} (default: @code{22})
Port number of SSH server on the machine.
@item private-key
The SSH private key file to use when connecting to the machine.
@item @code{private-key} (default: @file{~/.ssh/id_rsa})
The SSH private key file to use when connecting to the machine, in
OpenSSH format.
Currently offloading uses GNU@tie{}lsh as its SSH client
(@pxref{Invoking lsh,,, GNU lsh Manual}). Thus, the key file here must
be an lsh key file. This may change in the future, though.
@item @code{daemon-socket} (default: @code{"/var/guix/daemon-socket/socket"})
File name of the Unix-domain socket @command{guix-daemon} is listening
to on that machine.
@item parallel-builds
The number of builds that may run in parallel on the machine (1 by
default.)
@item @code{parallel-builds} (default: @code{1})
The number of builds that may run in parallel on the machine.
@item speed
@item @code{speed} (default: @code{1.0})
A ``relative speed factor''. The offload scheduler will tend to prefer
machines with a higher speed factor.
@item features
@item @code{features} (default: @code{'()})
A list of strings denoting specific features supported by the machine.
An example is @code{"kvm"} for machines that have the KVM Linux modules
and corresponding hardware support. Derivations can request features by
@ -915,7 +948,7 @@ machines, since offloading works by invoking the @code{guix archive} and
this is the case by running:
@example
lsh build-machine guile -c "'(use-modules (guix config))'"
ssh build-machine guile -c "'(use-modules (guix config))'"
@end example
There is one last thing to do once @file{machines.scm} is in place. As
@ -1209,6 +1242,56 @@ data in the right format.
This is important because the locale data format used by different libc
versions may be incompatible.
@subsection Name Service Switch
@cindex name service switch, glibc
@cindex NSS (name service switch), glibc
@cindex nscd (name service caching daemon)
@cindex name service caching daemon (nscd)
When using Guix on a foreign distro, we @emph{strongly recommend} that
the system run the GNU C library's @dfn{name service cache daemon},
@command{nscd}, which should be listening on the
@file{/var/run/nscd/socket} socket. Failing to do that, applications
installed with Guix may fail to look up host names or user accounts, or
may even crash. The next paragraphs explain why.
@cindex @file{nsswitch.conf}
The GNU C library implements a @dfn{name service switch} (NSS), which is
an extensible mechanism for ``name lookups'' in general: host name
resolution, user accounts, and more (@pxref{Name Service Switch,,, libc,
The GNU C Library Reference Manual}).
@cindex Network information service (NIS)
@cindex NIS (Network information service)
Being extensible, the NSS supports @dfn{plugins}, which provide new name
lookup implementations: for example, the @code{nss-mdns} plugin allow
resolution of @code{.local} host names, the @code{nis} plugin allows
user account lookup using the Network information service (NIS), and so
on. These extra ``lookup services'' are configured system-wide in
@file{/etc/nsswitch.conf}, and all the programs running on the system
honor those settings (@pxref{NSS Configuration File,,, libc, The GNU C
Reference Manual}).
When they perform a name lookup---for instance by calling the
@code{getaddrinfo} function in C---applications first try to connect to
the nscd; on success, nscd performs name lookups on their behalf. If
the nscd is not running, then they perform the name lookup by
themselves, by loading the name lookup services into their own address
space and running it. These name lookup services---the
@file{libnss_*.so} files---are @code{dlopen}'d, but they may come from
the host system's C library, rather than from the C library the
application is linked against (the C library coming from Guix).
And this is where the problem is: if your application is linked against
Guix's C library (say, glibc 2.24) and tries to load NSS plugins from
another C library (say, @code{libnss_mdns.so} for glibc 2.22), it will
likely crash or have its name lookups fail unexpectedly.
Running @command{nscd} on the system, among other advantages, eliminates
this binary incompatibility problem because those @code{libnss_*.so}
files are loaded in the @command{nscd} process, not in applications
themselves.
@subsection X11 Fonts
@cindex fonts
@ -5172,10 +5255,19 @@ gnu/packages/gettext.scm:29:13: gettext would be upgraded from 0.18.1.1 to 0.18.
gnu/packages/glib.scm:77:12: glib would be upgraded from 2.34.3 to 2.37.0
@end example
It does so by browsing the FTP directory of each package and determining
the highest version number of the source tarballs therein. The command
Alternately, one can specify packages to consider, in which case a
warning is emitted for packages that lack an updater:
@example
$ guix refresh coreutils guile guile-ssh
gnu/packages/ssh.scm:205:2: warning: no updater for guile-ssh
gnu/packages/guile.scm:136:12: guile would be upgraded from 2.0.12 to 2.0.13
@end example
@command{guix refresh} browses the upstream repository of each package and determines
the highest version number of the releases therein. The command
knows how to update specific types of packages: GNU packages, ELPA
packages, etc.---see the documentation for @option{--type} below. The
packages, etc.---see the documentation for @option{--type} below. There
are many packages, though, for which it lacks a method to determine
whether a new upstream release is available. However, the mechanism is
extensible, so feel free to get in touch with us to add a new method!
@ -5215,7 +5307,7 @@ usually run from a checkout of the Guix source tree (@pxref{Running
Guix Before It Is Installed}):
@example
$ ./pre-inst-env guix refresh -s non-core
$ ./pre-inst-env guix refresh -s non-core -u
@end example
@xref{Defining Packages}, for more information on package definitions.
@ -5281,7 +5373,7 @@ In addition, @command{guix refresh} can be passed one or more package
names, as in this example:
@example
$ ./pre-inst-env guix refresh -u emacs idutils gcc-4.8.4
$ ./pre-inst-env guix refresh -u emacs idutils gcc@@4.8
@end example
@noindent
@ -10025,7 +10117,7 @@ Return a service that runs @command{mysqld}, the MySQL or MariaDB
database server.
The optional @var{config} argument specifies the configuration for
@command{mysqld}, which should be a @code{<mysql-configuraiton>} object.
@command{mysqld}, which should be a @code{<mysql-configuration>} object.
@end deffn
@deftp {Data Type} mysql-configuration
@ -10047,16 +10139,11 @@ For MariaDB, the root password is empty.
@cindex mail
@cindex email
The @code{(gnu services mail)} module provides Guix service definitions
for mail services. Currently the only implemented service is Dovecot,
an IMAP, POP3, and LMTP server.
for email services: IMAP, POP3, and LMTP servers, as well as mail
transport agents (MTAs). Lots of acronyms! These services are detailed
in the subsections below.
Guix does not yet have a mail transfer agent (MTA), although for some
lightweight purposes the @code{esmtp} relay-only MTA may suffice. Help
is needed to properly integrate a full MTA, such as Postfix. Patches
welcome!
To add an IMAP/POP3 server to a GuixSD system, add a
@code{dovecot-service} to the operating system definition:
@subsubheading Dovecot Service
@deffn {Scheme Procedure} dovecot-service [#:config (dovecot-configuration)]
Return a service that runs the Dovecot IMAP/POP3/LMTP mail server.
@ -11412,6 +11499,35 @@ could instantiate a dovecot service like this:
(string "")))
@end example
@subsubheading OpenSMTPD Service
@deffn {Scheme Variable} opensmtpd-service-type
This is the type of the @uref{https://www.opensmtpd.org, OpenSMTPD}
service, whose value should be an @code{opensmtpd-configuration} object
as in this example:
@example
(service opensmtpd-service-type
(opensmtpd-configuration
(config-file (local-file "./my-smtpd.conf"))))
@end example
@end deffn
@deftp {Data Type} opensmtpd-configuration
Data type regresenting the configuration of opensmtpd.
@table @asis
@item @code{package} (default: @var{opensmtpd})
Package object of the OpenSMTPD SMTP server.
@item @code{config-file} (default: @var{%default-opensmtpd-file})
File-like object of the OpenSMTPD configuration file to use. By default
it listens on the loopback network interface, and allows for mail from
users and daemons on the local machine, as well as permitting email to
remote servers. Run @command{man smtpd.conf} for more information.
@end table
@end deftp
@node Kerberos Services
@subsubsection Kerberos Services

27
gnu/build/file-systems.scm
View File

@ -464,6 +464,27 @@ form:
DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f;
FLAGS must be a list of symbols. CHECK? is a Boolean indicating whether to
run a file system check."
(define (mount-nfs source mount-point type flags options)
(let* ((idx (string-rindex source #\:))
(host-part (string-take source idx))
;; Strip [] from around host if present
(host (match (string-split host-part (string->char-set "[]"))
(("" h "") h)
((h) h)))
(aa (match (getaddrinfo host "nfs") ((x . _) x)))
(sa (addrinfo:addr aa))
(inet-addr (inet-ntop (sockaddr:fam sa)
(sockaddr:addr sa))))
;; Mounting an NFS file system requires passing the address
;; of the server in the addr= option
(mount source mount-point type flags
(string-append "addr="
inet-addr
(if options
(string-append "," options)
"")))))
(match spec
((source title mount-point type (flags ...) options check?)
(let ((source (canonicalize-device-spec source title))
@ -481,7 +502,11 @@ run a file system check."
(call-with-output-file mount-point (const #t)))
(mkdir-p mount-point))
(mount source mount-point type flags options)
(cond
((string-prefix? "nfs" type)
(mount-nfs source mount-point type flags options))
(else
(mount source mount-point type flags options)))
;; For read-only bind mounts, an extra remount is needed, as per
;; <http://lwn.net/Articles/281157/>, which still applies to Linux 4.0.

16
gnu/build/vm.scm
View File

@ -79,12 +79,9 @@ it via /dev/hda.
REFERENCES-GRAPHS can specify a list of reference-graph files as produced by
the #:references-graphs parameter of 'derivation'."
(define image-file
(string-append "image." disk-image-format))
(when make-disk-image?
(unless (zero? (system* "qemu-img" "create" "-f" disk-image-format
image-file
output
(number->string disk-image-size)))
(error "qemu-img failed")))
@ -115,7 +112,7 @@ the #:references-graphs parameter of 'derivation'."
builder)
(append
(if make-disk-image?
`("-drive" ,(string-append "file=" image-file
`("-drive" ,(string-append "file=" output
",if=virtio"))
'())
;; Only enable kvm if we see /dev/kvm exists.
@ -126,11 +123,10 @@ the #:references-graphs parameter of 'derivation'."
'()))))
(error "qemu failed" qemu))
(if make-disk-image?
(copy-file image-file output)
(begin
(mkdir output)
(copy-recursively "xchg" output))))
;; When MAKE-DISK-IMAGE? is true, the image is in OUTPUT already.
(unless make-disk-image?
(mkdir output)
(copy-recursively "xchg" output)))
;;;

13
gnu/local.mk
View File

@ -187,6 +187,7 @@ GNU_SYSTEM_MODULES = \
%D%/packages/icu4c.scm \
%D%/packages/idutils.scm \
%D%/packages/image.scm \
%D%/packages/image-viewers.scm \
%D%/packages/imagemagick.scm \
%D%/packages/indent.scm \
%D%/packages/inklingreader.scm \
@ -294,6 +295,7 @@ GNU_SYSTEM_MODULES = \
%D%/packages/pdf.scm \
%D%/packages/pem.scm \
%D%/packages/perl.scm \
%D%/packages/perl-web.scm \
%D%/packages/photo.scm \
%D%/packages/php.scm \
%D%/packages/pkg-config.scm \
@ -305,7 +307,6 @@ GNU_SYSTEM_MODULES = \
%D%/packages/pumpio.scm \
%D%/packages/pretty-print.scm \
%D%/packages/protobuf.scm \
%D%/packages/psyc.scm \
%D%/packages/pv.scm \
%D%/packages/python.scm \
%D%/packages/qemu.scm \
@ -400,6 +401,7 @@ GNU_SYSTEM_MODULES = \
%D%/services/admin.scm \
%D%/services/avahi.scm \
%D%/services/base.scm \
%D%/services/configuration.scm \
%D%/services/cups.scm \
%D%/services/databases.scm \
%D%/services/dbus.scm \
@ -447,6 +449,7 @@ GNU_SYSTEM_MODULES = \
%D%/tests.scm \
%D%/tests/base.scm \
%D%/tests/install.scm \
%D%/tests/mail.scm \
%D%/tests/ssh.scm
@ -486,6 +489,7 @@ dist_patch_DATA = \
%D%/packages/patches/binutils-loongson-workaround.patch \
%D%/packages/patches/binutils-mips-bash-bug.patch \
%D%/packages/patches/byobu-writable-status.patch \
%D%/packages/patches/cairo-CVE-2016-9082.patch \
%D%/packages/patches/calibre-drop-unrar.patch \
%D%/packages/patches/calibre-no-updates-dialog.patch \
%D%/packages/patches/cdparanoia-fpic.patch \
@ -506,6 +510,7 @@ dist_patch_DATA = \
%D%/packages/patches/cssc-missing-include.patch \
%D%/packages/patches/clucene-contribs-lib.patch \
%D%/packages/patches/cursynth-wave-rand.patch \
%D%/packages/patches/cyrus-sasl-CVE-2013-4122.patch \
%D%/packages/patches/dbus-helper-search-path.patch \
%D%/packages/patches/devil-CVE-2009-3994.patch \
%D%/packages/patches/devil-fix-libpng.patch \
@ -551,6 +556,7 @@ dist_patch_DATA = \
%D%/packages/patches/gcc-5.0-libvtv-runpath.patch \
%D%/packages/patches/gcc-6-arm-none-eabi-multilib.patch \
%D%/packages/patches/gcc-6-cross-environment-variables.patch \
%D%/packages/patches/gcj-arm-mode.patch \
%D%/packages/patches/gd-CVE-2016-7568.patch \
%D%/packages/patches/gd-CVE-2016-8670.patch \
%D%/packages/patches/gd-fix-chunk-size-on-boundaries.patch \
@ -585,6 +591,10 @@ dist_patch_DATA = \
%D%/packages/patches/grub-gets-undeclared.patch \
%D%/packages/patches/grub-freetype.patch \
%D%/packages/patches/gsl-test-i686.patch \
%D%/packages/patches/gst-plugins-good-fix-crashes.patch \
%D%/packages/patches/gst-plugins-good-fix-invalid-read.patch \
%D%/packages/patches/gst-plugins-good-fix-signedness.patch \
%D%/packages/patches/gst-plugins-good-flic-bounds-check.patch \
%D%/packages/patches/guile-1.8-cpp-4.5.patch \
%D%/packages/patches/guile-arm-fixes.patch \
%D%/packages/patches/guile-default-utf8.patch \
@ -820,7 +830,6 @@ dist_patch_DATA = \
%D%/packages/patches/python-file-double-encoding-bug.patch \
%D%/packages/patches/python-fix-tests.patch \
%D%/packages/patches/python-parse-too-many-fields.patch \
%D%/packages/patches/python-rarfile-fix-tests.patch \
%D%/packages/patches/python2-rdflib-drop-sparqlwrapper.patch \
%D%/packages/patches/python-statsmodels-fix-tests.patch \
%D%/packages/patches/python-configobj-setuptools.patch \

16
gnu/packages/algebra.scm
View File

@ -576,6 +576,22 @@ cosine/ sine transforms or DCT/DST).")
(string-append (package-description fftw)
" Single-precision version."))))
;; FIXME: These packages are used temporarily by packages like Ardour until
;; "--enable-flags" is added to the fftw and fftwf packages.
(define-public fftw-with-threads
(package (inherit fftw)
(arguments
(substitute-keyword-arguments (package-arguments fftw)
((#:configure-flags flags)
`(cons "--enable-threads" ,flags))))))
(define-public fftwf-with-threads
(package (inherit fftwf)
(arguments
(substitute-keyword-arguments (package-arguments fftwf)
((#:configure-flags flags)
`(cons "--enable-threads" ,flags))))))
(define-public fftw-openmpi
(package (inherit fftw)
(name "fftw-openmpi")

4
gnu/packages/aspell.scm
View File

@ -108,10 +108,10 @@ dictionaries, including personal ones.")
(define-public aspell-dict-en
(aspell-dictionary "en" "English"
#:version "2016.01.19-0"
#:version "2016.11.20-0"
#:sha256
(base32
"01h4cl4lngp6mcfbyb47cjrc2gspyg2519dvknd97ki896nx7vcn")))
"1496jnhh2jvhkzcj0p4vy89bcs4g5wz6a76m33vw4dhchn5xm9jw")))
(define-public aspell-dict-eo
(aspell-dictionary "eo" "Esperanto"

11
gnu/packages/audio.scm
View File

@ -238,8 +238,8 @@ namespace ARDOUR { const char* revision = \"5.4\" ; }"))))
("lv2" ,lv2)
("vamp" ,vamp)
("curl" ,curl)
("fftw" ,fftw)
("fftwf" ,fftwf)
("fftw" ,fftw-with-threads)
("fftwf" ,fftwf-with-threads)
("jack" ,jack-1)
("serd" ,serd)
("sord" ,sord)
@ -1552,15 +1552,14 @@ significantly faster and have minimal dependencies.")
(define-public lv2
(package
(name "lv2")
(version "1.12.0")
(version "1.14.0")
(source (origin
(method url-fetch)
(uri (string-append "http://lv2plug.in/spec/lv2-"
version
".tar.bz2"))
version ".tar.bz2"))
(sha256
(base32
"1saq0vwqy5zjdkgc5ahs8kcabxfmff2mmg68fiqrkv8hiw9m6jks"))))
"0chxwys3vnn3nxc9x2vchm74s9sx0vfra6y893byy12ci61jc1dq"))))
(build-system waf-build-system)
(arguments
`(#:tests? #f ; no check target

254
gnu/packages/bioinformatics.scm
View File

@ -50,6 +50,7 @@
#:use-module (gnu packages documentation)
#:use-module (gnu packages datastructures)
#:use-module (gnu packages file)
#:use-module (gnu packages flex)
#:use-module (gnu packages gawk)
#:use-module (gnu packages gcc)
#:use-module (gnu packages gd)
@ -3435,6 +3436,45 @@ program for nucleotide and protein sequences.")
;; License information found in 'muscle -h' and usage.cpp.
(license license:public-domain)))
(define-public newick-utils
;; There are no recent releases so we package from git.
(let ((commit "da121155a977197cab9fbb15953ca1b40b11eb87"))
(package
(name "newick-utils")
(version (string-append "1.6-1." (string-take commit 8)))
(source (origin
(method git-fetch)
(uri (git-reference
(url "https://github.com/tjunier/newick_utils.git")
(commit commit)))
(file-name (string-append name "-" version "-checkout"))
(sha256
(base32
"1hkw21rq1mwf7xp0rmbb2gqc0i6p11108m69i7mr7xcjl268pxnb"))))
(build-system gnu-build-system)
(arguments
`(#:phases
(modify-phases %standard-phases
(add-after 'unpack 'autoconf
(lambda _ (zero? (system* "autoreconf" "-vif")))))))
(inputs
;; XXX: TODO: Enable Lua and Guile bindings.
;; https://github.com/tjunier/newick_utils/issues/13
`(("libxml2" ,libxml2)
("flex" ,flex)
("bison" ,bison)))
(native-inputs
`(("autoconf" ,autoconf)
("automake" ,automake)
("libtool" ,libtool)))
(synopsis "Programs for working with newick format phylogenetic trees")
(description
"Newick-utils is a suite of utilities for processing phylogenetic trees
in Newick format. Functions include re-rooting, extracting subtrees,
trimming, pruning, condensing, drawing (ASCII graphics or SVG).")
(home-page "https://github.com/tjunier/newick_utils")
(license license:bsd-3))))
(define-public orfm
(package
(name "orfm")
@ -3635,6 +3675,58 @@ for sequences to be aligned and then, simultaneously with the alignment,
predicts the locations of structural units in the sequences.")
(license license:gpl2+)))
(define-public proteinortho
(package
(name "proteinortho")
(version "5.15")
(source
(origin
(method url-fetch)
(uri
(string-append
"http://www.bioinf.uni-leipzig.de/Software/proteinortho/proteinortho_v"
version "_src.tar.gz"))
(sha256
(base32
"05wacnnbx56avpcwhzlcf6b7s77swcpv3qnwz5sh1z54i51gg2ki"))))
(build-system gnu-build-system)
(arguments
`(#:test-target "test"
#:phases
(modify-phases %standard-phases
(replace 'configure
;; There is no configure script, so we modify the Makefile directly.
(lambda* (#:key outputs #:allow-other-keys)
(substitute* "Makefile"
(("INSTALLDIR=.*")
(string-append
"INSTALLDIR=" (assoc-ref outputs "out") "/bin\n")))
#t))
(add-before 'install 'make-install-directory
;; The install directory is not created during 'make install'.
(lambda* (#:key outputs #:allow-other-keys)
(mkdir-p (string-append (assoc-ref outputs "out") "/bin"))
#t))
(add-after 'install 'wrap-programs
(lambda* (#:key inputs outputs #:allow-other-keys)
(let* ((path (getenv "PATH"))
(out (assoc-ref outputs "out"))
(binary (string-append out "/bin/proteinortho5.pl")))
(wrap-program binary `("PATH" ":" prefix (,path))))
#t)))))
(inputs
`(("perl" ,perl)
("python" ,python-2)
("blast+" ,blast+)))
(home-page "http://www.bioinf.uni-leipzig.de/Software/proteinortho")
(synopsis "Detect orthologous genes across species")
(description
"Proteinortho is a tool to detect orthologous genes across different
species. For doing so, it compares similarities of given gene sequences and
clusters them to find significant groups. The algorithm was designed to handle
large-scale data and can be applied to hundreds of species at once.")
(license license:gpl2+)))
(define-public pyicoteo
(package
(name "pyicoteo")
@ -3707,7 +3799,7 @@ partial genes, and identifies translation initiation sites.")
(define-public roary
(package
(name "roary")
(version "3.6.8")
(version "3.7.0")
(source
(origin
(method url-fetch)
@ -3716,7 +3808,7 @@ partial genes, and identifies translation initiation sites.")
version ".tar.gz"))
(sha256
(base32
"0g0pzcv8y7n2w8q7c9q0a7s2ghkwci6w8smg9mjw4agad5cd7yaw"))))
"0x2hpb3nfsc6x2nq1788w0fhqfzc7cn2dp4xwyva9m3k6xlz0m43"))))
(build-system perl-build-system)
(arguments
`(#:phases
@ -7182,6 +7274,29 @@ two-dimensional genome scans.")
libraries for systems that do not have these available via other means.")
(license license:artistic2.0)))
(define-public r-r4rna
(package
(name "r-r4rna")
(version "0.1.4")
(source
(origin
(method url-fetch)
(uri (string-append "http://www.e-rna.org/r-chie/files/R4RNA_"
version ".tar.gz"))
(sha256
(base32
"1p0i78wh76jfgmn9jphbwwaz6yy6pipzfg08xs54cxavxg2j81p5"))))
(build-system r-build-system)
(propagated-inputs
`(("r-optparse" ,r-optparse)
("r-rcolorbrewer" ,r-rcolorbrewer)))
(home-page "http://www.e-rna.org/r-chie/index.cgi")
(synopsis "Analysis framework for RNA secondary structure")
(description
"The R4RNA package aims to be a general framework for the analysis of RNA
secondary structure and comparative analysis in R.")
(license license:gpl3+)))
(define-public r-rhtslib
(package
(name "r-rhtslib")
@ -7362,6 +7477,141 @@ characterization and visualization of a wide range of mutational patterns
in SNV base substitution data.")
(license license:expat)))
(define-public r-wgcna
(package
(name "r-wgcna")
(version "1.51")
(source
(origin
(method url-fetch)
(uri (cran-uri "WGCNA" version))
(sha256
(base32
"0hzvnhw76vwg8bl8x368f0c5szpwb8323bmrb3bir93i5bmfjsxx"))))
(properties `((upstream-name . "WGCNA")))
(build-system r-build-system)
(propagated-inputs
`(("r-annotationdbi" ,r-annotationdbi)
("r-doparallel" ,r-doparallel)
("r-dynamictreecut" ,r-dynamictreecut)
("r-fastcluster" ,r-fastcluster)
("r-foreach" ,r-foreach)
("r-go-db" ,r-go-db)
("r-hmisc" ,r-hmisc)
("r-impute" ,r-impute)
("r-matrixstats" ,r-matrixstats)
("r-preprocesscore" ,r-preprocesscore)))
(home-page
"http://www.genetics.ucla.edu/labs/horvath/CoexpressionNetwork/Rpackages/WGCNA/")
(synopsis "Weighted correlation network analysis")
(description
"This package provides functions necessary to perform Weighted
Correlation Network Analysis on high-dimensional data. It includes functions
for rudimentary data cleaning, construction and summarization of correlation
networks, module identification and functions for relating both variables and
modules to sample traits. It also includes a number of utility functions for
data manipulation and visualization.")
(license license:gpl2+)))
(define-public r-chipkernels
(let ((commit "c9cfcacb626b1221094fb3490ea7bac0fd625372")
(revision "1"))
(package
(name "r-chipkernels")
(version (string-append "1.1-" revision "." (string-take commit 9)))
(source
(origin
(method git-fetch)
(uri (git-reference
(url "https://github.com/ManuSetty/ChIPKernels.git")
(commit commit)))
(file-name (string-append name "-" version))
(sha256
(base32
"14bj5qhjm1hsm9ay561nfbqi9wxsa7y487df2idsaaf6z10nw4v0"))))
(build-system r-build-system)
(propagated-inputs
`(("r-iranges" ,r-iranges)
("r-xvector" ,r-xvector)
("r-biostrings" ,r-biostrings)
("r-bsgenome" ,r-bsgenome)
("r-gtools" ,r-gtools)
("r-genomicranges" ,r-genomicranges)
("r-sfsmisc" ,r-sfsmisc)
("r-kernlab" ,r-kernlab)
("r-s4vectors" ,r-s4vectors)
("r-biocgenerics" ,r-biocgenerics)))
(home-page "https://github.com/ManuSetty/ChIPKernels")
(synopsis "Build string kernels for DNA Sequence analysis")
(description "ChIPKernels is an R package for building different string
kernels used for DNA Sequence analysis. A dictionary of the desired kernel
must be built and this dictionary can be used for determining kernels for DNA
Sequences.")
(license license:gpl2+))))
(define-public r-seqgl
(package
(name "r-seqgl")
(version "1.1.4")
(source
(origin
(method url-fetch)
(uri (string-append "https://github.com/ManuSetty/SeqGL/"
"archive/" version ".tar.gz"))
(file-name (string-append name "-" version ".tar.gz"))
(sha256
(base32
"0pnk1p3sci5yipyc8xnb6jbmydpl80fld927xgnbcv104hy8h8yh"))))
(build-system r-build-system)
(propagated-inputs
`(("r-biostrings" ,r-biostrings)
("r-chipkernels" ,r-chipkernels)
("r-genomicranges" ,r-genomicranges)
("r-spams" ,r-spams)
("r-wgcna" ,r-wgcna)
("r-fastcluster" ,r-fastcluster)))
(home-page "https://github.com/ManuSetty/SeqGL")
(synopsis "Group lasso for Dnase/ChIP-seq data")
(description "SeqGL is a group lasso based algorithm to extract
transcription factor sequence signals from ChIP, DNase and ATAC-seq profiles.
This package presents a method which uses group lasso to discriminate between
bound and non bound genomic regions to accurately identify transcription
factors bound at the specific regions.")
(license license:gpl2+)))
(define-public r-gkmsvm
(package
(name "r-gkmsvm")
(version "0.71.0")
(source
(origin
(method url-fetch)
(uri (cran-uri "gkmSVM" version))
(sha256
(base32
"1zpxgxmf2nd5j5wn00ps6kfxr8wxh7d1swr1rr4spq7sj5z5z0k0"))))
(properties `((upstream-name . "gkmSVM")))
(build-system r-build-system)
(propagated-inputs
`(("r-biocgenerics" ,r-biocgenerics)
("r-biostrings" ,r-biostrings)
("r-genomeinfodb" ,r-genomeinfodb)
("r-genomicranges" ,r-genomicranges)
("r-iranges" ,r-iranges)
("r-kernlab" ,r-kernlab)
("r-rcpp" ,r-rcpp)
("r-rocr" ,r-rocr)
("r-rtracklayer" ,r-rtracklayer)
("r-s4vectors" ,r-s4vectors)
("r-seqinr" ,r-seqinr)))
(home-page "http://cran.r-project.org/web/packages/gkmSVM")
(synopsis "Gapped-kmer support vector machine")
(description
"This R package provides tools for training gapped-kmer SVM classifiers
for DNA and protein sequences. This package supports several sequence
kernels, including: gkmSVM, kmer-SVM, mismatch kernel and wildcard kernel.")
(license license:gpl2+)))
(define-public emboss
(package
(name "emboss")

5
gnu/packages/bittorrent.scm
View File

@ -49,7 +49,7 @@
(define-public transmission
(package
(name "transmission")
(version "2.84")
(version "2.92")
(source (origin
(method url-fetch)
(uri (string-append
@ -57,7 +57,7 @@
version ".tar.xz"))
(sha256
(base32
"1sxr1magqb5s26yvr5yhs1f7bmir8gl09niafg64lhgfnhv1kz59"))))
"0pykmhi7pdmzq47glbj8i2im6iarp4wnj4l1pyvsrnba61f0939s"))))
(build-system glib-or-gtk-build-system)
(outputs '("out" ; library and command-line interface
"gui")) ; graphical user interface
@ -84,6 +84,7 @@
`(("inotify-tools" ,inotify-tools)
("libevent" ,libevent)
("curl" ,curl)
("cyrus-sasl" ,cyrus-sasl)
("openssl" ,openssl)
("file" ,file)
("zlib" ,zlib)

4
gnu/packages/crypto.scm
View File

@ -56,7 +56,7 @@
(define-public libsodium
(package
(name "libsodium")
(version "1.0.10")
(version "1.0.11")
(source (origin
(method url-fetch)
(uri (list (string-append
@ -67,7 +67,7 @@
"releases/old/libsodium-" version ".tar.gz")))
(sha256
(base32
"1gn45g956lyz8l6iq187yc6l627vyivyp8qc5dkr6dnhdnlqddvi"))))
"0rf7z6bgpnf8lyz8sph4h43fbb28pmj4dgybf0hsxxj97kdljid1"))))
(build-system gnu-build-system)
(synopsis "Portable NaCl-based crypto library")
(description

9
gnu/packages/cyrus-sasl.scm
View File

@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2016 Leo Famulari <leo@famulari.name>
;;;
;;; This file is part of GNU Guix.
;;;
@ -30,6 +31,7 @@
(define-public cyrus-sasl
(package
(name "cyrus-sasl")
(replacement cyrus-sasl/fixed)
(version "2.1.26")
(source (origin
(method url-fetch)
@ -64,3 +66,10 @@ server writers.")
(license (license:non-copyleft "file://COPYING"
"See COPYING in the distribution."))
(home-page "http://cyrusimap.web.cmu.edu")))
(define cyrus-sasl/fixed
(package
(inherit cyrus-sasl)
(source (origin
(inherit (package-source cyrus-sasl))
(patches (search-patches "cyrus-sasl-CVE-2013-4122.patch"))))))

6
gnu/packages/databases.scm
View File

@ -819,15 +819,15 @@ columns, primary keys, unique constraints and relationships.")
(define-public perl-dbd-mysql
(package
(name "perl-dbd-mysql")
(version "4.039")
(version "4.041")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://cpan/authors/id/C/CA/CAPTTOFU/"
(uri (string-append "mirror://cpan/authors/id/M/MI/MICHIELB/"
"DBD-mysql-" version ".tar.gz"))
(sha256
(base32
"0k4p3bjdbmxm2amb0qiiwmn8v83zrjkz5qp84xdjrg8k5v9aj0hn"))))
"0h4h6zwzj8fwh9ljb8svnsa0a3ch4p10hp59kpdibdb4qh8xwxs7"))))
(build-system perl-build-system)
;; Tests require running MySQL server
(arguments `(#:tests? #f))

4
gnu/packages/enlightenment.scm
View File

@ -56,7 +56,7 @@
(define-public efl
(package
(name "efl")
(version "1.18.2")
(version "1.18.3")
(source (origin
(method url-fetch)
(uri (string-append
@ -64,7 +64,7 @@
version ".tar.xz"))
(sha256
(base32
"1vbvsrrpkvvrmvjavwnp5q77kw5i7vmbaj2vq5mnmrbzamvaybr9"))))
"1h347sfxajyb5s931m9qga14wwiqci7aicww2imxjhzm8w4fqj07"))))
(build-system gnu-build-system)
(native-inputs
`(("pkg-config" ,pkg-config)))

36
gnu/packages/fonts.scm
View File

@ -13,6 +13,7 @@
;;; Copyright © 2016 Dmitry Nikolaev <cameltheman@gmail.com>
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2016 Marius Bakke <mbakke@fastmail.com>
;;; Copyright © 2016 Toni Reina <areina@riseup.net>
;;;
;;; This file is part of GNU Guix.
;;;
@ -898,3 +899,38 @@ powerline support.")
"Source Code Pro is a set of monospaced OpenType fonts that have been
designed to work well in user interface environments.")
(license license:silofl1.1)))
(define-public font-fira-mono
(package
(name "font-fira-mono")
(version "3.206")
(source (origin
(method url-fetch)
(uri (string-append "https://carrois.com/downloads/fira_mono_3_2/"
"FiraMonoFonts"
(string-replace-substring version "." "")
".zip"))
(sha256
(base32
"1z65x0dw5dq6rs6p9wyfrir50rlh95vgzsxr8jcd40nqazw4jhpi"))))
(build-system trivial-build-system)
(arguments
`(#:modules ((guix build utils))
#:builder
(begin
(use-modules (guix build utils))
(let ((unzip (string-append (assoc-ref %build-inputs "unzip")
"/bin/unzip"))
(font-dir (string-append %output "/share/fonts/opentype")))
(mkdir-p font-dir)
(system* unzip
"-j"
(assoc-ref %build-inputs "source")
"*.otf"
"-d" font-dir)))))
(native-inputs
`(("unzip" ,unzip)))
(home-page "http://mozilla.github.io/Fira/")
(synopsis "Mozilla's monospace font")
(description "This is the typeface used by Mozilla in Firefox OS.")
(license license:silofl1.1)))

27
gnu/packages/freedesktop.scm
View File

@ -450,17 +450,19 @@ Analysis and Reporting Technology) functionality.")
(define-public udisks
(package
(name "udisks")
(version "2.1.7")
(version "2.1.8")
(source (origin
(method url-fetch)
(uri (string-append "https://udisks.freedesktop.org/releases/"
name "-" version ".tar.bz2"))
(sha256
(base32
"119pr2zbff8vkwlhghim7d7ir24c1dil9hp4q49wm4f6pnrjpbmb"))))
"1nkxhnqh39c9pzvm4zfj50rgv6apqawdx09bv3sfaxrah4a6jhfs"))))
(build-system gnu-build-system)
(native-inputs
`(("glib:bin" ,glib "bin") ; for glib-mkenums
`(("docbook-xml" ,docbook-xml-4.3) ; to build the manpages
("docbook-xsl" ,docbook-xsl)
("glib:bin" ,glib "bin") ; for glib-mkenums
("gobject-introspection" ,gobject-introspection)
("intltool" ,intltool)
("pkg-config" ,pkg-config)
@ -479,13 +481,28 @@ Analysis and Reporting Technology) functionality.")
`(#:tests? #f ; requiring system message dbus
#:disallowed-references ("doc") ;enforce separation of "doc"
#:configure-flags
(list "--disable-man"
(list "--enable-man"
"--localstatedir=/var"
"--enable-fhs-media" ;mount devices in /media, not /run/media
(string-append "--with-html-dir="
(assoc-ref %outputs "doc")
"/share/doc/udisks/html")
(string-append "--with-udevdir=" %output "/lib/udev"))
#:make-flags
(let* ((docbook-xsl-name-version ,(string-append
(package-name docbook-xsl) "-"
(package-version docbook-xsl)))
(docbook-xsl-catalog-file (string-append
(assoc-ref %build-inputs "docbook-xsl")
"/xml/xsl/"
docbook-xsl-name-version
"/catalog.xml"))
(docbook-xml-catalog-file (string-append
(assoc-ref %build-inputs "docbook-xml")
"/xml/dtd/docbook/catalog.xml")))
;; Reference the catalog files required to build the manpages.
(list (string-append "XML_CATALOG_FILES=" docbook-xsl-catalog-file " "
docbook-xml-catalog-file)))
#:phases
(modify-phases %standard-phases
(add-before
@ -508,7 +525,7 @@ Analysis and Reporting Technology) functionality.")
"/run/current-system/profile/bin"
"/run/current-system/profile/sbin")))
#t))))))
(home-page "http://www.freedesktop.org/wiki/Software/udisks/")
(home-page "https://www.freedesktop.org/wiki/Software/udisks/")
(synopsis "Disk manager service")
(description
"UDisks provides interfaces to enumerate and perform operations on disks

8
gnu/packages/gcc.scm
View File

@ -521,6 +521,10 @@ as the 'native-search-paths' field."
(define-public gcj
(package (inherit gcc)
(name "gcj")
(version (package-version gcc))
(source (origin (inherit (package-source gcc))
(patches (cons (search-patch "gcj-arm-mode.patch")
(origin-patches (package-source gcc))))))
(inputs
`(("fastjar" ,fastjar)
("perl" ,perl)
@ -568,6 +572,10 @@ as the 'native-search-paths' field."
'unpack 'patch-testsuite
;; dejagnu-1.6 removes the 'absolute' command
(lambda _
;; This test fails on armhf. It seems harmless enough to disable it.
(for-each delete-file '("libjava/testsuite/libjava.lang/Throw_2.java"
"libjava/testsuite/libjava.lang/Throw_2.out"
"libjava/testsuite/libjava.lang/Throw_2.jar"))
(substitute* "libjava/testsuite/lib/libjava.exp"
(("absolute") "file normalize"))
#t))

5
gnu/packages/gstreamer.scm
View File

@ -4,6 +4,7 @@
;;; Copyright © 2015, 2016 Sou Bunnbu <iyzsong@gmail.com>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2016 Leo Famulari <leo@famulari.name>
;;;
;;; This file is part of GNU Guix.
;;;
@ -207,6 +208,10 @@ for the GStreamer multimedia library.")
(uri (string-append
"https://gstreamer.freedesktop.org/src/" name "/"
name "-" version ".tar.xz"))
(patches (search-patches "gst-plugins-good-flic-bounds-check.patch"
"gst-plugins-good-fix-signedness.patch"
"gst-plugins-good-fix-invalid-read.patch"
"gst-plugins-good-fix-crashes.patch"))
(sha256
(base32
"1hkcap9l2603266gyi6jgvx7frbvfmb7xhfhjizbczy1wykjwr57"))))

12
gnu/packages/gtk.scm
View File

@ -100,6 +100,7 @@ tools have full access to view and control running applications.")
(define-public cairo
(package
(name "cairo")
(replacement cairo/fixed)
(version "1.14.6")
(source (origin
(method url-fetch)
@ -153,6 +154,10 @@ affine transformation (scale, rotation, shear, etc.).")
(package
(inherit cairo)
(name "cairo-xcb")
(source (origin
(inherit (package-source cairo))
(patches (search-patches "cairo-CVE-2016-9082.patch"))))
(replacement #f)
(inputs
`(("mesa" ,mesa)
,@(package-inputs cairo)))
@ -162,6 +167,13 @@ affine transformation (scale, rotation, shear, etc.).")
'("--enable-xlib-xcb" "--enable-gl" "--enable-egl")))
(synopsis "2D graphics library (with X11 support)")))
(define cairo/fixed
(package
(inherit cairo)
(source (origin
(inherit (package-source cairo))
(patches (search-patches "cairo-CVE-2016-9082.patch"))))))
(define-public harfbuzz
(package
(name "harfbuzz")

78
gnu/packages/image-viewers.scm Normal file
View File

@ -0,0 +1,78 @@
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;;
;;; 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 image-viewers)
#:use-module ((guix licenses) #:prefix license:)
#:use-module (guix download)
#:use-module (guix packages)
#:use-module (guix build-system gnu)
#:use-module (gnu packages autotools)
#:use-module (gnu packages base)
#:use-module (gnu packages geeqie)
#:use-module (gnu packages glib)
#:use-module (gnu packages gnome)
#:use-module (gnu packages gtk)
#:use-module (gnu packages pkg-config))
(define-public viewnior
(package
(name "viewnior")
(version "1.6")
(source
(origin
(method url-fetch)
(uri (string-append "https://github.com/xsisqox/Viewnior/archive/"
name "-" version ".tar.gz"))
(sha256
(base32
"18309qjgwak3kn228z3p3nx7yxasqgzx69v3rgc23hf161nky0c9"))))
(build-system gnu-build-system)
(arguments
'(#:phases
(modify-phases %standard-phases
(add-after 'unpack 'autogen
(lambda _
(zero? (system* "sh" "autogen.sh")))))))
(native-inputs
`(("automake" ,automake)
("autoconf" ,autoconf)
("intltool" ,intltool)
("glib" ,glib "bin") ; glib-genmarshal
("gnome-common" ,gnome-common)
("libtool" ,libtool)
("pkg-config" ,pkg-config)
("shared-mime-info" ,shared-mime-info)
("which" ,which)))
(inputs
`(("exiv2" ,exiv2)
("gdk-pixbuf" ,gdk-pixbuf)
("gtk+-2" ,gtk+-2)))
(home-page "http://siyanpanayotov.com/project/viewnior/")
(synopsis "Simple, fast and elegant image viewer")
(description "Viewnior is an image viewer program. Created to be simple,
fast and elegant. Its minimalistic interface provides more screenspace for
your images. Among its features are:
@enumerate
@item Fullscreen & Slideshow
@item Rotate, flip, crop, save, delete images
@item Animation support
@item Browse only selected images
@item Navigation window
@item Set image as wallpaper (Gnome 2, Gnome 3, XFCE, LXDE, FluxBox, Nitrogen)
@item Simple interface
@item EXIF and IPTC metadata
@item Configurable mouse actions
@end enumerate\n")
(license license:gpl3+)))

6
gnu/packages/image.scm
View File

@ -843,15 +843,15 @@ convert, manipulate, filter and display a wide variety of image formats.")
(define-public jasper
(package
(name "jasper")
(version "1.900.29")
(version "2.0.0")
(source (origin
(method url-fetch)
(uri (string-append "https://www.ece.uvic.ca/~frodo/jasper"
"/software/jasper-" version ".tar.gz"))
(sha256
(base32
"1h1575wdzq1p7y2xvy1gbiypai1iils5awhy4gadr78qpb9ykrra"))))
(build-system gnu-build-system)
"1kg5yrdwgazhbczybyx4548m0ijssabcp8hl5l87w78z833vikks"))))
(build-system cmake-build-system)
(inputs `(("libjpeg" ,libjpeg)))
(synopsis "JPEG-2000 library")
(description "The JasPer Project is an initiative to provide a reference

4
gnu/packages/imagemagick.scm
View File

@ -43,14 +43,14 @@
(define-public imagemagick
(package
(name "imagemagick")
(version "6.9.6-5")
(version "6.9.6-6")
(source (origin
(method url-fetch)
(uri (string-append "mirror://imagemagick/ImageMagick-"
version ".tar.xz"))
(sha256
(base32
"037lg2m0y5b17lyi34jdlkq4h03ck67j5m6wr84nvwd3jfx240cd"))))
"02hd0xvpm99wrix2didg8xnra4fla04y9vaks2vnijry3l0gxlcw"))))
(build-system gnu-build-system)
(arguments
`(#:configure-flags '("--with-frozenpaths" "--without-gcc-arch")

3
gnu/packages/kde-frameworks.scm
View File

@ -1030,7 +1030,8 @@ which are used in DBus communication.")
(home-page "https://community.kde.org/Frameworks")
(synopsis "Oxygen provides the standard icon theme for the KDE desktop")
(description "Oxygen icon theme for the KDE desktop")
(license license:lgpl3+)))
(license license:lgpl3+)
(properties '((upstream-name . "oxygen-icons5")))))
(define-public solid
(package

20
gnu/packages/ldc.scm
View File

@ -29,6 +29,7 @@
#:use-module (gnu packages compression)
#:use-module (gnu packages libedit)
#:use-module (gnu packages llvm)
#:use-module (gnu packages python)
#:use-module (gnu packages textutils)
#:use-module (gnu packages zip))
@ -76,7 +77,7 @@ and freshness without requiring additional information from the user.")
(define-public ldc
(package
(name "ldc")
(version "0.16.1")
(version "0.17.2")
(source (origin
(method url-fetch)
(uri (string-append
@ -85,10 +86,9 @@ and freshness without requiring additional information from the user.")
(file-name (string-append name "-" version ".tar.gz"))
(sha256
(base32
"1jvilxx0rpqmkbja4m69fhd5g09697xq7vyqp2hz4hvxmmmv4j40"))))
"0iksl6cvhsiwnlh15b7s9v8f3grxk27jn0vja9n4sad7fvfwmmlc"))))
(build-system cmake-build-system)
;; LDC currently only supports the x86_64 and i686 architectures.
(supported-systems '("x86_64-linux" "i686-linux"))
(supported-systems '("x86_64-linux" "i686-linux" "armhf-linux"))
(arguments
`(#:phases
(modify-phases %standard-phases
@ -127,8 +127,10 @@ and freshness without requiring additional information from the user.")
("tzdata" ,tzdata)
("zlib" ,zlib)))
(native-inputs
`(("llvm" ,llvm-3.7)
("clang" ,clang-3.7)
`(("llvm" ,llvm)
("clang" ,clang)
("python-lit" ,python-lit)
("python-wrapper" ,python-wrapper)
("unzip" ,unzip)
("phobos-src"
,(origin
@ -138,7 +140,7 @@ and freshness without requiring additional information from the user.")
version ".tar.gz"))
(sha256
(base32
"0sgdj0536c4nb118yiw1f8lqy5d3g3lpg9l99l165lk9xy45l9z4"))
"07hh3ic3r755mq9hn9gfr0wlc5y8cr91xz2ydb6gqy4zy8jgp5s9"))
(patches (search-patches "ldc-disable-tests.patch"))))
("druntime-src"
,(origin
@ -148,7 +150,7 @@ and freshness without requiring additional information from the user.")
version ".tar.gz"))
(sha256
(base32
"0z4mkyddx6c4sy1vqgqvavz55083dsxws681qkh93jh1rpby9yg6"))))
"1m1dhday9dl3s04njmd29z7ism2xn2ksb9qlrwzykdgz27b3dk6x"))))
("dmd-testsuite-src"
,(origin
(method url-fetch)
@ -157,7 +159,7 @@ and freshness without requiring additional information from the user.")
version ".tar.gz"))
(sha256
(base32
"0yc6miidzgl9k33ygk7xcppmfd6kivqj02cvv4fmkbs3qz4yy3z1"))))))
"0n7gvalxwfmia4gag53r9qhcnk2cqrw3n4icj1yri0zkgc27pm60"))))))
(home-page "http://wiki.dlang.org/LDC")
(synopsis "LLVM compiler for the D programming language")
(description

22
gnu/packages/machine-learning.scm
View File

@ -479,6 +479,28 @@ geometric models.")
single hidden layer, and for multinomial log-linear models.")
(license (list license:gpl2+ license:gpl3+))))
(define-public r-kernlab
(package
(name "r-kernlab")
(version "0.9-25")
(source
(origin
(method url-fetch)
(uri (cran-uri "kernlab" version))
(sha256
(base32
"0qnaq9x3j2xc6jrmmd98wc6hkzch487s4p3a9lnc00xvahkhgpmr"))))
(build-system r-build-system)
(home-page "http://cran.r-project.org/web/packages/kernlab")
(synopsis "Kernel-based machine learning tools")
(description
"This package provides kernel-based machine learning methods for
classification, regression, clustering, novelty detection, quantile regression
and dimensionality reduction. Among other methods @code{kernlab} includes
Support Vector Machines, Spectral Clustering, Kernel PCA, Gaussian Processes
and a QP solver.")
(license license:gpl2)))
(define-public dlib
(package
(name "dlib")

13
gnu/packages/mail.scm
View File

@ -329,7 +329,7 @@ and corrections. It is based on a Bayesian filter.")
(define-public offlineimap
(package
(name "offlineimap")
(version "7.0.9")
(version "7.0.10")
(source (origin
(method url-fetch)
(uri (string-append "https://github.com/OfflineIMAP/offlineimap/"
@ -337,7 +337,7 @@ and corrections. It is based on a Bayesian filter.")
(file-name (string-append name "-" version ".tar.gz"))
(sha256
(base32
"04kapx0ddz7ccwhcjshkml2y916wcan3rl28mpmq25p4gywlkhxf"))))
"0h8mgmwkvwh8x3yam32ipqkzcz4g1dmkbni3v1755lkm0z132m3j"))))
(build-system python-build-system)
(native-inputs
`(("asciidoc" ,asciidoc)
@ -537,14 +537,14 @@ invoking @command{notifymuch} from the post-new hook.")
(define-public notmuch
(package
(name "notmuch")
(version "0.23.2")
(version "0.23.3")
(source (origin
(method url-fetch)
(uri (string-append "https://notmuchmail.org/releases/notmuch-"
version ".tar.gz"))
(sha256
(base32
"1g4p5hsrqqbqk6s2w756als60wppvjgpyq104smy3w9vshl7bzgd"))))
"10hqjnl5aavf9clfmx3y832jyz58fplmc3f58pip9dq30b7sap8g"))))
(build-system gnu-build-system)
(arguments
'(#:make-flags (list "V=1") ; Verbose test output.
@ -568,11 +568,6 @@ invoking @command{notifymuch} from the post-new hook.")
;; Patch various inline shell invocations.
(substitute* (find-files "test" "\\.sh$")
(("/bin/sh") (which "sh")))
;; XXX: Some signature verification tests fail with
;; gnupg-2.1.16, so we skip them. See this thread:
;; https://notmuchmail.org/pipermail/notmuch/2016/023688.html
(setenv "NOTMUCH_SKIP_TESTS"
"T350-crypto.2 T350-crypto.3 T350-crypto.4 T350-crypto.15")
#t)))))
(native-inputs
`(("bash-completion" ,bash-completion)

196
gnu/packages/messaging.scm
View File

@ -5,7 +5,7 @@
;;; Copyright © 2015 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2015, 2016 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2015 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2016 ng0 <ngillmann@runbox.com>
;;; Copyright © 2016 ng0 <ng0@libertad.pw>
;;; Copyright © 2016 Andy Patterson <ajpatter@uwaterloo.ca>
;;; Copyright © 2016 Clément Lassieur <clement@lassieur.org>
;;;
@ -33,6 +33,7 @@
#:use-module (guix build-system gnu)
#:use-module (guix build-system glib-or-gtk)
#:use-module (guix build-system python)
#:use-module (guix build-system perl)
#:use-module (gnu packages)
#:use-module (gnu packages aidc)
#:use-module (gnu packages autotools)
@ -43,11 +44,13 @@
#:use-module (gnu packages databases)
#:use-module (gnu packages documentation)
#:use-module (gnu packages enchant)
#:use-module (gnu packages gettext)
#:use-module (gnu packages gnome)
#:use-module (gnu packages gtk)
#:use-module (gnu packages xorg)
#:use-module (gnu packages xdisorg)
#:use-module (gnu packages libcanberra)
#:use-module (gnu packages man)
#:use-module (gnu packages networking)
#:use-module (gnu packages libidn)
#:use-module (gnu packages lua)
@ -57,6 +60,7 @@
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages glib)
#:use-module (gnu packages python)
#:use-module (gnu packages pcre)
#:use-module (gnu packages perl)
#:use-module (gnu packages tcl)
#:use-module (gnu packages compression)
@ -67,8 +71,10 @@
#:use-module (gnu packages icu4c)
#:use-module (gnu packages qt)
#:use-module (gnu packages video)
#:use-module (gnu packages web)
#:use-module (gnu packages xiph)
#:use-module (gnu packages audio)
#:use-module (gnu packages bison)
#:use-module (gnu packages fontutils))
(define-public libotr
@ -859,4 +865,192 @@ into existing applications.")
(home-page "https://camaya.net/gloox")
(license license:gpl3)))
(define-public perl-net-psyc
(package
(name "perl-net-psyc")
(version "1.1")
(source
(origin
(method url-fetch)
(uri (string-append "http://perlpsyc.psyc.eu/"
"perlpsyc-" version ".zip"))
(file-name (string-append name "-" version ".zip"))
(sha256
(base32
"1lw6807qrbmvzbrjn1rna1dhir2k70xpcjvyjn45y35hav333a42"))
;; psycmp3 currently depends on MP3::List and rxaudio (shareware),
;; we can add it back when this is no longer the case.
(snippet '(delete-file "contrib/psycmp3"))))
(build-system perl-build-system)
(inputs
`(("perl-curses" ,perl-curses)
("perl-io-socket-ssl" ,perl-io-socket-ssl)))
(arguments
`(#:phases
(modify-phases %standard-phases
(delete 'configure) ; No configure script
;; There is a Makefile, but it does not install everything
;; (leaves out psycion) and says
;; "# Just to give you a rough idea". XXX: Fix it upstream.
(replace 'build
(lambda _
(zero? (system* "make" "manuals"))))
(replace 'install
(lambda* (#:key outputs #:allow-other-keys)
(let* ((out (assoc-ref outputs "out"))
(doc (string-append out "/share/doc/perl-net-psyc"))
(man1 (string-append out "/share/man/man1"))
(man3 (string-append out "/share/man/man3"))
(bin (string-append out "/bin"))
(libpsyc (string-append out "/lib/psyc/ion"))
(libperl (string-append out "/lib/perl5/site_perl/"
,(package-version perl))))
(copy-recursively "lib/perl5" libperl)
(copy-recursively "lib/psycion" libpsyc)
(copy-recursively "bin" bin)
(install-file "cgi/psycpager" (string-append doc "/cgi"))
(copy-recursively "contrib" (string-append doc "/contrib"))
(copy-recursively "hooks" (string-append doc "/hooks"))
(copy-recursively "sdj" (string-append doc "/sdj"))
(install-file "README.txt" doc)
(install-file "TODO.txt" doc)
(copy-recursively "share/man/man1" man1)
(copy-recursively "share/man/man3" man3)
#t)))
(add-after 'install 'wrap-programs
(lambda* (#:key outputs #:allow-other-keys)
;; Make sure all executables in "bin" find the Perl modules
;; provided by this package at runtime.
(let* ((out (assoc-ref outputs "out"))
(bin (string-append out "/bin/"))
(path (getenv "PERL5LIB")))
(for-each (lambda (file)
(wrap-program file
`("PERL5LIB" ":" prefix (,path))))
(find-files bin "\\.*$"))
#t))))))
(description
"@code{Net::PSYC} with support for TCP, UDP, Event.pm, @code{IO::Select} and
Gtk2 event loops. This package includes 12 applications and additional scripts:
psycion (a @uref{http://about.psyc.eu,PSYC} chat client), remotor (a control console
for @uref{https://torproject.org,tor} router) and many more.")
(synopsis "Perl implementation of PSYC protocol")
(home-page "http://perlpsyc.psyc.eu/")
(license (list license:gpl2
(package-license perl)
;; contrib/irssi-psyc.pl:
license:public-domain
;; bin/psycplay states AGPL with no version:
license:agpl3+))))
(define-public libpsyc
(package
(name "libpsyc")
(version "20160913")
(source (origin
(method url-fetch)
(uri (string-append "http://www.psyced.org/files/"
name "-" version ".tar.xz"))
(sha256
(base32
"14q89fxap05ajkfn20rnhc6b1h4i3i2adyr7y6hs5zqwb2lcmc1p"))))
(build-system gnu-build-system)
(native-inputs
`(("perl" ,perl)
("netcat" ,netcat)
("procps" ,procps)))
(arguments
`(#:make-flags
(list "CC=gcc"
(string-append "PREFIX=" (assoc-ref %outputs "out")))
#:phases
(modify-phases %standard-phases
;; The rust bindings are the only ones in use, the lpc bindings
;; are in psyclpc. The other bindings are not used by anything,
;; the chances are high that the bindings do not even work,
;; therefore we do not include them.
;; TODO: Get a cargo build system in Guix.
(delete 'configure)))) ; no configure script
(home-page "http://about.psyc.eu/libpsyc")
(description
"@code{libpsyc} is a PSYC library in C which implements
core aspects of PSYC, useful for all kinds of clients and servers
including psyced.")
(synopsis "PSYC library in C")
(license license:agpl3+)))
;; This commit removes the historic bundled pcre and makes psyclpc reproducible.
(define-public psyclpc
(let* ((commit "61cf9aa81297085e5c40170fd01221c752f8deba")
(revision "2"))
(package
(name "psyclpc")
(version (string-append "20160821-" revision "." (string-take commit 7)))
(source (origin
(method git-fetch)
(uri (git-reference
(url "git://git.psyced.org/git/psyclpc")
(commit commit)))
(file-name (string-append name "-" version "-checkout"))
(sha256
(base32
"1viwqymbhn3cwvx0zl58rlzl5gw47zxn0ldg2nbi55ghm5zxl1z5"))))
(build-system gnu-build-system)
(arguments
`(#:tests? #f ; There are no tests/checks.
#:configure-flags
;; If you have questions about this part, look at
;; "src/settings/psyced" and the ebuild.
(list
"--enable-use-tls=yes"
"--enable-use-mccp" ; Mud Client Compression Protocol, leave this enabled.
(string-append "--prefix="
(assoc-ref %outputs "out"))
;; src/Makefile: Set MUD_LIB to the directory which contains
;; the mud data. defaults to MUD_LIB = @libdir@
(string-append "--libdir="
(assoc-ref %outputs "out")
"/opt/psyced/world")
(string-append "--bindir="
(assoc-ref %outputs "out")
"/opt/psyced/bin")
;; src/Makefile: Set ERQ_DIR to directory which contains the
;; stuff which ERQ can execute (hopefully) savely. Was formerly
;; defined in config.h. defaults to ERQ_DIR= @libexecdir@
(string-append "--libexecdir="
(assoc-ref %outputs "out")
"/opt/psyced/run"))
#:phases
(modify-phases %standard-phases
(add-before 'configure 'chdir-to-src
;; We need to pass this as env variables
;; and manually change the directory.
(lambda _
(chdir "src")
(setenv "CONFIG_SHELL" (which "sh"))
(setenv "SHELL" (which "sh"))
#t)))
#:make-flags (list "install-all")))
(inputs
`(("zlib" ,zlib)
("openssl" ,openssl)
("pcre" ,pcre)))
(native-inputs
`(("pkg-config" ,pkg-config)
("bison" ,bison)
("gettext" ,gettext-minimal)
("help2man" ,help2man)
("autoconf" ,autoconf)
("automake" ,automake)))
(home-page "http://lpc.psyc.eu/")
(synopsis "psycLPC is a multi-user network server programming language")
(description
"LPC is a bytecode language, invented to specifically implement
multi user virtual environments on the internet. This technology is used for
MUDs and also the psyced implementation of the Protocol for SYnchronous
Conferencing (PSYC). psycLPC is a fork of LDMud with some new features and
many bug fixes.")
(license license:gpl2))))
;;; messaging.scm ends here

104
gnu/packages/music.scm
View File

@ -234,7 +234,7 @@ many input formats and provides a customisable Vi-style user interface.")
(define-public hydrogen
(package
(name "hydrogen")
(version "0.9.6.1")
(version "0.9.7")
(source (origin
(method url-fetch)
(uri (string-append
@ -242,7 +242,7 @@ many input formats and provides a customisable Vi-style user interface.")
version ".tar.gz"))
(sha256
(base32
"0vxnaqfmcv7hhk0cj67imdcqngspnck7f0wfmvhfgfqa7x1xznll"))))
"1dy2jfkdw0nchars4xi4isrz66fqn53a9qk13bqza7lhmsg3s3qy"))))
(build-system cmake-build-system)
(arguments
`(#:test-target "tests"))
@ -588,11 +588,12 @@ Guile.")
(define-public non-sequencer
;; The latest tagged release is three years old and uses a custom build
;; system, so we take the last commit affecting the "sequencer" directory.
(let ((commit "1d9bd576f6bf7ea240af5f7a60260592750af0dd"))
;; system, so we take the last commit.
(let ((commit "a22f33f486a5c6f75b60e36f66504c036c0f6f8c")
(revision "2"))
(package
(name "non-sequencer")
(version (string-append "1.9.5-" (string-take commit 7)))
(version (string-append "1.9.5-" revision "." (string-take commit 7)))
(source (origin
(method git-fetch)
(uri (git-reference
@ -600,7 +601,7 @@ Guile.")
(commit commit)))
(sha256
(base32
"0pkkw8q6d55j38xm7r4rwpdv1wy00a44h8c4wrn7vbgpq9nij46y"))
"09q5x8i4f8mqnl8w6xnsq5zriy4bzdl4x2vq9n34a433rfrk84bg"))
(file-name (string-append name "-" version "-checkout"))))
(build-system waf-build-system)
(arguments
@ -638,6 +639,28 @@ Sequencer happens on-line, in real-time. Music can be composed live, while the
transport is rolling.")
(license license:gpl2+))))
(define-public non-session-manager
(package (inherit non-sequencer)
(name "non-session-manager")
(arguments
(substitute-keyword-arguments (package-arguments non-sequencer)
((#:configure-flags flags)
`(cons "--project=session-manager"
(delete "--project=sequencer" ,flags)))))
(inputs
`(("jack" ,jack-1)
("liblo" ,liblo)
("ntk" ,ntk)))
(native-inputs
`(("pkg-config" ,pkg-config)))
(home-page "http://non.tuxfamily.org/nsm/")
(synopsis "Audio session management")
(description
"The Non Session Manager is an API and an implementation for audio
session management. NSM clients use a well-specified OSC protocol to
communicate with the session management daemon.")
(license license:gpl2+)))
(define-public solfege
(package
(name "solfege")
@ -1744,8 +1767,8 @@ analogue-like user interface.")
#t)))))
(inputs
`(("lilv" ,lilv)
("fftw" ,fftw)
("fftwf" ,fftwf)
("fftw" ,fftw-with-threads)
("fftwf" ,fftwf-with-threads)
("lv2" ,lv2)
("jack" ,jack-1)
("readline" ,readline)))
@ -1796,14 +1819,16 @@ event-based scripts for scrobbling, notifications, etc.")
(define-public python-mutagen
(package
(name "python-mutagen")
(version "1.31")
(version "1.35.1")
(source (origin
(method url-fetch)
(uri (pypi-uri "mutagen" version))
(sha256
(base32
"16fnnhspniac2i7qswxafawsh2x2a803hmc6bn9k1zl5fxq1380a"))))
"0klk68c1n3285vvm2xzk8ii7mlqp1dxii04askan0gi1wlpagka9"))))
(build-system python-build-system)
(native-inputs
`(("python-pytest" ,python-pytest)))
(home-page "https://bitbucket.org/lazka/mutagen")
(synopsis "Read and write audio tags")
(description "Mutagen is a Python module to handle audio metadata. It
@ -1821,14 +1846,18 @@ streams on an individual packet/page level.")
(define-public python-musicbrainzngs
(package
(name "python-musicbrainzngs")
(version "0.5")
(version "0.6")
(source (origin
(method url-fetch)
(uri (pypi-uri "musicbrainzngs" version))
(sha256
(base32
"12f48llmdf5rkiqxcb70k2k1dmhm8byq0ifazvlrca8dfnmqh4r8"))))
"1dddarpjawryll2wss65xq3v9q8ln8dan7984l5dxzqx88d2dvr8"))))
(build-system python-build-system)
(arguments
'(;; The tests fail suffer from race conditions:
;; https://github.com/alastair/python-musicbrainzngs/issues/211
#:tests? #f))
(home-page "https://python-musicbrainzngs.readthedocs.org/")
(synopsis "Python bindings for MusicBrainz NGS webservice")
(description "Musicbrainzngs implements Python bindings of the MusicBrainz
@ -1876,13 +1905,13 @@ detailed track info including timbre, pitch, rhythm and loudness information.
(define-public python-pylast
(package
(name "python-pylast")
(version "1.5.1")
(version "1.6.0")
(source (origin
(method url-fetch)
(uri (pypi-uri "pylast" version))
(sha256
(base32
"10znd9xr1vs2ix519jkz3ccm90zciaddcdr2w2wrrh2jyy3bc59a"))))
"0bml11gfkxqd3i2jxkn5k2xllc4rvxjcyhs8an05gcyy1zp2bwvb"))))
(build-system python-build-system)
(native-inputs
`(("python-coverage" ,python-coverage)
@ -1905,16 +1934,20 @@ websites such as Libre.fm.")
(define-public beets
(package
(name "beets")
(version "1.3.19")
(version "1.4.1")
(source (origin
(method url-fetch)
(uri (pypi-uri "beets" version))
(sha256
(base32
"1vi1dh3fr554bnm8y9pjy09hblw18v6cl2jppzwlp72afri1w93b"))))
"14yn88xrcinpdg3ic285ar0wmwldzyjfd3ll6clmp3z3r4iqffip"))))
(build-system python-build-system)
(arguments
`(#:python ,python-2 ; only Python 2 is supported
`(;; Python 3 support is still "alpha", and the upstream maintainers ask
;; packagers not to use it yet:
;; https://github.com/beetbox/beets/releases/tag/v1.4.1
;; TODO Check this again for the next release.
#:python ,python-2
#:phases
(modify-phases %standard-phases
(add-after 'unpack 'set-HOME
@ -1935,7 +1968,8 @@ websites such as Libre.fm.")
("python2-responses" ,python2-responses)))
;; TODO: Install optional plugins and dependencies.
(inputs
`(("python2-enum34" ,python2-enum34)
`(("python2-discogs-client" ,python2-discogs-client)
("python2-enum34" ,python2-enum34)
("python2-jellyfish" ,python2-jellyfish)
("python2-munkres" ,python2-munkres)
("python2-musicbrainzngs" ,python2-musicbrainzngs)
@ -2413,3 +2447,37 @@ a simulation of an analog Wah pedal with switchless activation."))))
filters, crossovers, simple gain plugins without zipper noise, switch box
plugins, a switch trigger, a toggle switch, and a peakmeter.")
(license license:gpl2+))))
(define-public python-discogs-client
(package
(name "python-discogs-client")
(version "2.2.1")
(source (origin
(method url-fetch)
(uri (pypi-uri "discogs-client" version))
(sha256
(base32
"053ld2psh0yj3z0kg6z5bn4y3cr562m727494n0ayhgzbkjbacly"))))
(build-system python-build-system)
(propagated-inputs
`(("python-oauthlib" ,python-oauthlib)
("python-requests" ,python-requests)))
(native-inputs
`(("python-six" ,python-six)))
(home-page "https://github.com/discogs/discogs_client")
(synopsis "Official Python client for the Discogs API")
(description "This is the official Discogs API client for Python. It enables
you to query the Discogs database for information on artists, releases, labels,
users, Marketplace listings, and more. It also supports OAuth 1.0a
authorization, which allows you to change user data such as profile information,
collections and wantlists, inventory, and orders.")
(license license:bsd-2)
(properties `((python2-variant . ,(delay python2-discogs-client))))))
(define-public python2-discogs-client
(let ((base (package-with-python2
(strip-python2-variant python-discogs-client))))
(package (inherit base)
(native-inputs
`(("python2-setuptools" ,python2-setuptools)
,@(package-native-inputs base))))))

55
gnu/packages/ntp.scm
View File

@ -39,33 +39,34 @@
(define-public ntp
(package
(name "ntp")
(version "4.2.8p8")
(source (origin
(method url-fetch)
(uri (list (string-append
"http://archive.ntp.org/ntp4/ntp-"
(version-major+minor version)
"/ntp-" version ".tar.gz")
(string-append
"https://www.eecis.udel.edu/~ntp/ntp_spool/ntp4/ntp-"
(version-major+minor version)
"/ntp-" version ".tar.gz")))
(sha256
(base32
"1vlpgd0dk2wkpmmf869sfxi8f46sfnmjgk51vl8n6vj5y2sx1cra"))
(modules '((guix build utils)))
(snippet
'(begin
;; Remove the bundled copy of libevent, but we must keep
;; sntp/libevent/build-aux since configure.ac contains
;; AC_CONFIG_AUX_DIR([sntp/libevent/build-aux])
(rename-file "sntp/libevent/build-aux"
"sntp/libevent:build-aux")
(delete-file-recursively "sntp/libevent")
(mkdir "sntp/libevent")
(rename-file "sntp/libevent:build-aux"
"sntp/libevent/build-aux")
#t))))
(version "4.2.8p9")
(source
(origin
(method url-fetch)
(uri (list (string-append
"http://archive.ntp.org/ntp4/ntp-"
(version-major+minor version)
"/ntp-" version ".tar.gz")
(string-append
"https://www.eecis.udel.edu/~ntp/ntp_spool/ntp4/ntp-"
(version-major+minor version)
"/ntp-" version ".tar.gz")))
(sha256
(base32
"0whbyf82lrczbri4adbsa4hg1ppfa6c7qcj7nhjwdfp1g1vjh95p"))
(modules '((guix build utils)))
(snippet
'(begin
;; Remove the bundled copy of libevent, but we must keep
;; sntp/libevent/build-aux since configure.ac contains
;; AC_CONFIG_AUX_DIR([sntp/libevent/build-aux])
(rename-file "sntp/libevent/build-aux"
"sntp/libevent:build-aux")
(delete-file-recursively "sntp/libevent")
(mkdir "sntp/libevent")
(rename-file "sntp/libevent:build-aux"
"sntp/libevent/build-aux")
#t))))
(native-inputs `(("which" ,which)
("pkg-config" ,pkg-config)))
(inputs

122
gnu/packages/patches/cairo-CVE-2016-9082.patch Normal file
View File

@ -0,0 +1,122 @@
From: Adrian Johnson <ajohnson@redneon.com>
Date: Thu, 20 Oct 2016 21:12:30 +1030
Subject: [PATCH] image: prevent invalid ptr access for > 4GB images
Image data is often accessed using:
image->data + y * image->stride
On 64-bit achitectures if the image data is > 4GB, this computation
will overflow since both y and stride are 32-bit types.
bug report: https://bugs.freedesktop.org/show_bug.cgi?id=98165
patch: https://bugs.freedesktop.org/attachment.cgi?id=127421
---
boilerplate/cairo-boilerplate.c | 4 +++-
src/cairo-image-compositor.c | 4 ++--
src/cairo-image-surface-private.h | 2 +-
src/cairo-mesh-pattern-rasterizer.c | 2 +-
src/cairo-png.c | 2 +-
src/cairo-script-surface.c | 3 ++-
6 files changed, 10 insertions(+), 7 deletions(-)
diff --git a/boilerplate/cairo-boilerplate.c b/boilerplate/cairo-boilerplate.c
index 7fdbf79..4804dea 100644
--- a/boilerplate/cairo-boilerplate.c
+++ b/boilerplate/cairo-boilerplate.c
@@ -42,6 +42,7 @@
#undef CAIRO_VERSION_H
#include "../cairo-version.h"
+#include <stddef.h>
#include <stdlib.h>
#include <ctype.h>
#include <assert.h>
@@ -976,7 +977,8 @@ cairo_surface_t *
cairo_boilerplate_image_surface_create_from_ppm_stream (FILE *file)
{
char format;
- int width, height, stride;
+ int width, height;
+ ptrdiff_t stride;
int x, y;
unsigned char *data;
cairo_surface_t *image = NULL;
diff --git a/src/cairo-image-compositor.c b/src/cairo-image-compositor.c
index 48072f8..3ca0006 100644
--- a/src/cairo-image-compositor.c
+++ b/src/cairo-image-compositor.c
@@ -1575,7 +1575,7 @@ typedef struct _cairo_image_span_renderer {
pixman_image_t *src, *mask;
union {
struct fill {
- int stride;
+ ptrdiff_t stride;
uint8_t *data;
uint32_t pixel;
} fill;
@@ -1594,7 +1594,7 @@ typedef struct _cairo_image_span_renderer {
struct finish {
cairo_rectangle_int_t extents;
int src_x, src_y;
- int stride;
+ ptrdiff_t stride;
uint8_t *data;
} mask;
} u;
diff --git a/src/cairo-image-surface-private.h b/src/cairo-image-surface-private.h
index 8ca694c..7e78d61 100644
--- a/src/cairo-image-surface-private.h
+++ b/src/cairo-image-surface-private.h
@@ -71,7 +71,7 @@ struct _cairo_image_surface {
int width;
int height;
- int stride;
+ ptrdiff_t stride;
int depth;
unsigned owns_data : 1;
diff --git a/src/cairo-mesh-pattern-rasterizer.c b/src/cairo-mesh-pattern-rasterizer.c
index 1b63ca8..e7f0db6 100644
--- a/src/cairo-mesh-pattern-rasterizer.c
+++ b/src/cairo-mesh-pattern-rasterizer.c
@@ -470,7 +470,7 @@ draw_pixel (unsigned char *data, int width, int height, int stride,
tg += tg >> 16;
tb += tb >> 16;
- *((uint32_t*) (data + y*stride + 4*x)) = ((ta << 16) & 0xff000000) |
+ *((uint32_t*) (data + y*(ptrdiff_t)stride + 4*x)) = ((ta << 16) & 0xff000000) |
((tr >> 8) & 0xff0000) | ((tg >> 16) & 0xff00) | (tb >> 24);
}
}
diff --git a/src/cairo-png.c b/src/cairo-png.c
index 562b743..aa8c227 100644
--- a/src/cairo-png.c
+++ b/src/cairo-png.c
@@ -673,7 +673,7 @@ read_png (struct png_read_closure_t *png_closure)
}
for (i = 0; i < png_height; i++)
- row_pointers[i] = &data[i * stride];
+ row_pointers[i] = &data[i * (ptrdiff_t)stride];
png_read_image (png, row_pointers);
png_read_end (png, info);
diff --git a/src/cairo-script-surface.c b/src/cairo-script-surface.c
index ea0117d..91e4baa 100644
--- a/src/cairo-script-surface.c
+++ b/src/cairo-script-surface.c
@@ -1202,7 +1202,8 @@ static cairo_status_t
_write_image_surface (cairo_output_stream_t *output,
const cairo_image_surface_t *image)
{
- int stride, row, width;
+ int row, width;
+ ptrdiff_t stride;
uint8_t row_stack[CAIRO_STACK_BUFFER_SIZE];
uint8_t *rowdata;
uint8_t *data;
--
2.1.4

130
gnu/packages/patches/cyrus-sasl-CVE-2013-4122.patch Normal file
View File

@ -0,0 +1,130 @@
Fix CVE-2013-4122.
https://cve.mitre.org/cgi-bin/cvename.cgi?name=CVE-2013-4122
Patch copied from upstream source repository:
https://github.com/cyrusimap/cyrus-sasl/commit/dedad73e5e7a75d01a5f3d5a6702ab8ccd2ff40d
From dedad73e5e7a75d01a5f3d5a6702ab8ccd2ff40d Mon Sep 17 00:00:00 2001
From: mancha <mancha1@hush.com>
Date: Thu, 11 Jul 2013 10:08:07 +0100
Subject: Handle NULL returns from glibc 2.17+ crypt()
Starting with glibc 2.17 (eglibc 2.17), crypt() fails with EINVAL
(w/ NULL return) if the salt violates specifications. Additionally,
on FIPS-140 enabled Linux systems, DES/MD5-encrypted passwords
passed to crypt() fail with EPERM (w/ NULL return).
When using glibc's crypt(), check return value to avoid a possible
NULL pointer dereference.
Patch by mancha1@hush.com.
---
pwcheck/pwcheck_getpwnam.c | 3 ++-
pwcheck/pwcheck_getspnam.c | 4 +++-
saslauthd/auth_getpwent.c | 4 +++-
saslauthd/auth_shadow.c | 8 +++-----
4 files changed, 11 insertions(+), 8 deletions(-)
diff --git a/pwcheck/pwcheck_getpwnam.c b/pwcheck/pwcheck_getpwnam.c
index 4b34222..400289c 100644
--- a/pwcheck/pwcheck_getpwnam.c
+++ b/pwcheck/pwcheck_getpwnam.c
@@ -32,6 +32,7 @@ char *userid;
char *password;
{
char* r;
+ char* crpt_passwd;
struct passwd *pwd;
pwd = getpwnam(userid);
@@ -41,7 +42,7 @@ char *password;
else if (pwd->pw_passwd[0] == '*') {
r = "Account disabled";
}
- else if (strcmp(pwd->pw_passwd, crypt(password, pwd->pw_passwd)) != 0) {
+ else if (!(crpt_passwd = crypt(password, pwd->pw_passwd)) || strcmp(pwd->pw_passwd, (const char *)crpt_passwd) != 0) {
r = "Incorrect password";
}
else {
diff --git a/pwcheck/pwcheck_getspnam.c b/pwcheck/pwcheck_getspnam.c
index 2b11286..6d607bb 100644
--- a/pwcheck/pwcheck_getspnam.c
+++ b/pwcheck/pwcheck_getspnam.c
@@ -32,13 +32,15 @@ char *userid;
char *password;
{
struct spwd *pwd;
+ char *crpt_passwd;
pwd = getspnam(userid);
if (!pwd) {
return "Userid not found";
}
- if (strcmp(pwd->sp_pwdp, crypt(password, pwd->sp_pwdp)) != 0) {
+ crpt_passwd = crypt(password, pwd->sp_pwdp);
+ if (!crpt_passwd || strcmp(pwd->sp_pwdp, (const char *)crpt_passwd) != 0) {
return "Incorrect password";
}
else {
diff --git a/saslauthd/auth_getpwent.c b/saslauthd/auth_getpwent.c
index fc8029d..d4ebe54 100644
--- a/saslauthd/auth_getpwent.c
+++ b/saslauthd/auth_getpwent.c
@@ -77,6 +77,7 @@ auth_getpwent (
{
/* VARIABLES */
struct passwd *pw; /* pointer to passwd file entry */
+ char *crpt_passwd; /* encrypted password */
int errnum;
/* END VARIABLES */
@@ -105,7 +106,8 @@ auth_getpwent (
}
}
- if (strcmp(pw->pw_passwd, (const char *)crypt(password, pw->pw_passwd))) {
+ crpt_passwd = crypt(password, pw->pw_passwd);
+ if (!crpt_passwd || strcmp(pw->pw_passwd, (const char *)crpt_passwd)) {
if (flags & VERBOSE) {
syslog(LOG_DEBUG, "DEBUG: auth_getpwent: %s: invalid password", login);
}
diff --git a/saslauthd/auth_shadow.c b/saslauthd/auth_shadow.c
index 677131b..1988afd 100644
--- a/saslauthd/auth_shadow.c
+++ b/saslauthd/auth_shadow.c
@@ -210,8 +210,8 @@ auth_shadow (
RETURN("NO Insufficient permission to access NIS authentication database (saslauthd)");
}
- cpw = strdup((const char *)crypt(password, sp->sp_pwdp));
- if (strcmp(sp->sp_pwdp, cpw)) {
+ cpw = crypt(password, sp->sp_pwdp);
+ if (!cpw || strcmp(sp->sp_pwdp, (const char *)cpw)) {
if (flags & VERBOSE) {
/*
* This _should_ reveal the SHADOW_PW_LOCKED prefix to an
@@ -221,10 +221,8 @@ auth_shadow (
syslog(LOG_DEBUG, "DEBUG: auth_shadow: pw mismatch: '%s' != '%s'",
sp->sp_pwdp, cpw);
}
- free(cpw);
RETURN("NO Incorrect password");
}
- free(cpw);
/*
* The following fields will be set to -1 if:
@@ -286,7 +284,7 @@ auth_shadow (
RETURN("NO Invalid username");
}
- if (strcmp(upw->upw_passwd, crypt(password, upw->upw_passwd)) != 0) {
+ if (!(cpw = crypt(password, upw->upw_passwd)) || (strcmp(upw->upw_passwd, (const char *)cpw) != 0)) {
if (flags & VERBOSE) {
syslog(LOG_DEBUG, "auth_shadow: pw mismatch: %s != %s",
password, upw->upw_passwd);
--
cgit v0.12

36
gnu/packages/patches/gcj-arm-mode.patch Normal file
View File

@ -0,0 +1,36 @@
Taken from
https://sources.debian.net/data/main/g/gcc-4.9/4.9.2-10/debian/patches/gcj-arm-mode.diff
# DP: For armhf, force arm mode instead of thumb mode
--- a/libjava/configure.host
+++ b/libjava/configure.host
@@ -66,6 +66,9 @@
;;
esac
+# on armhf force arm mode
+libgcj_flags="${libgcj_flags} -marm"
+
AM_RUNTESTFLAGS=
# Set any host dependent compiler flags.
--- a/gcc/java/lang-specs.h
+++ b/gcc/java/lang-specs.h
@@ -47,7 +47,7 @@
%{.class|.zip|.jar|!fsyntax-only:jc1 \
%{.java|fsaw-java-file:%U.jar -fsource-filename=%i %<ffilelist-file} \
%{.class|.zip|.jar|ffilelist-file|fcompile-resource*:%i} \
- %(jc1) %(cc1_options) %{I*} %{!findirect-dispatch:-faux-classpath %U.zip} \
+ %(jc1) %(cc1_options) -marm %{I*} %{!findirect-dispatch:-faux-classpath %U.zip} \
%{MD:-MD_} %{MMD:-MMD_} %{M} %{MM} %{MA} %{MT*} %{MF*}\
%(invoke_as)}",
0, 0, 0},
--- a/libjava/libgcj.spec.in
+++ b/libjava/libgcj.spec.in
@@ -9,4 +9,4 @@
%rename lib liborig
*lib: @LD_START_STATIC_SPEC@ @LIBGCJ_SPEC@ @LD_FINISH_STATIC_SPEC@ @LIBMATHSPEC@ @LDLIBICONV@ @GCSPEC@ @THREADSPEC@ @ZLIBSPEC@ @SYSTEMSPEC@ %(libgcc) @LIBSTDCXXSPEC@ %(liborig)
-*jc1: @HASH_SYNC_SPEC@ @DIVIDESPEC@ @CHECKREFSPEC@ @JC1GCSPEC@ @EXCEPTIONSPEC@ @BACKTRACESPEC@ @IEEESPEC@ @ATOMICSPEC@ @LIBGCJ_BC_SPEC@ -fkeep-inline-functions
+*jc1: @HASH_SYNC_SPEC@ @DIVIDESPEC@ @CHECKREFSPEC@ @JC1GCSPEC@ @EXCEPTIONSPEC@ @BACKTRACESPEC@ @IEEESPEC@ @ATOMICSPEC@ @LIBGCJ_BC_SPEC@ -fkeep-inline-functions -marm

1047
gnu/packages/patches/gst-plugins-good-fix-crashes.patch Normal file
View File

File diff suppressed because it is too large Load Diff

37
gnu/packages/patches/gst-plugins-good-fix-invalid-read.patch Normal file
View File

@ -0,0 +1,37 @@
Fixes upstream bug #774897 (flxdec: Unreferences itself one time too many on
invalid files):
https://bugzilla.gnome.org/show_bug.cgi?id=774897
Patch copied from upstream source repository:
https://cgit.freedesktop.org/gstreamer/gst-plugins-good/commit/?id=b31c504645a814c59d91d49e4fe218acaf93f4ca
From b31c504645a814c59d91d49e4fe218acaf93f4ca Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Sebastian=20Dr=C3=B6ge?= <sebastian@centricular.com>
Date: Wed, 23 Nov 2016 11:20:49 +0200
Subject: [PATCH] flxdec: Don't unref() parent in the chain function
We don't own the reference here, it is owned by the caller and given to
us for the scope of this function. Leftover mistake from 0.10 porting.
https://bugzilla.gnome.org/show_bug.cgi?id=774897
---
gst/flx/gstflxdec.c | 1 -
1 file changed, 1 deletion(-)
diff --git a/gst/flx/gstflxdec.c b/gst/flx/gstflxdec.c
index e675c99..a237976 100644
--- a/gst/flx/gstflxdec.c
+++ b/gst/flx/gstflxdec.c
@@ -677,7 +677,6 @@ wrong_type:
{
GST_ELEMENT_ERROR (flxdec, STREAM, WRONG_TYPE, (NULL),
("not a flx file (type %x)", flxh->type));
- gst_object_unref (flxdec);
return GST_FLOW_ERROR;
}
}
--
2.10.2

58
gnu/packages/patches/gst-plugins-good-fix-signedness.patch Normal file
View File

@ -0,0 +1,58 @@
This is a followup fix for upstream bug #774834 (flic decoder: Buffer overflow
in flx_decode_delta_fli):
https://bugzilla.gnome.org/show_bug.cgi?id=774834#c2
Patch copied from upstream source repository:
https://cgit.freedesktop.org/gstreamer/gst-plugins-good/commit/?id=1ab2b26193861b124426e2f8eb62b75b59ec5488
From 1ab2b26193861b124426e2f8eb62b75b59ec5488 Mon Sep 17 00:00:00 2001
From: Matthew Waters <matthew@centricular.com>
Date: Tue, 22 Nov 2016 23:46:00 +1100
Subject: [PATCH] flxdec: fix some warnings comparing unsigned < 0
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
bf43f44fcfada5ec4a3ce60cb374340486fe9fac was comparing an unsigned
expression to be < 0 which was always false.
gstflxdec.c: In function ‘flx_decode_brun’:
gstflxdec.c:322:33: warning: comparison of unsigned expression < 0 is always false [-Wtype-limits]
if ((glong) row - count < 0) {
^
gstflxdec.c:332:33: warning: comparison of unsigned expression < 0 is always false [-Wtype-limits]
if ((glong) row - count < 0) {
^
https://bugzilla.gnome.org/show_bug.cgi?id=774834
---
gst/flx/gstflxdec.c | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/gst/flx/gstflxdec.c b/gst/flx/gstflxdec.c
index d51a8e6..e675c99 100644
--- a/gst/flx/gstflxdec.c
+++ b/gst/flx/gstflxdec.c
@@ -319,7 +319,7 @@ flx_decode_brun (GstFlxDec * flxdec, guchar * data, guchar * dest)
if (count > 0x7f) {
/* literal run */
count = 0x100 - count;
- if ((glong) row - count < 0) {
+ if ((glong) row - (glong) count < 0) {
GST_ERROR_OBJECT (flxdec, "Invalid BRUN packet detected.");
return FALSE;
}
@@ -329,7 +329,7 @@ flx_decode_brun (GstFlxDec * flxdec, guchar * data, guchar * dest)
*dest++ = *data++;
} else {
- if ((glong) row - count < 0) {
+ if ((glong) row - (glong) count < 0) {
GST_ERROR_OBJECT (flxdec, "Invalid BRUN packet detected.");
return FALSE;
}
--
2.10.2

319
gnu/packages/patches/gst-plugins-good-flic-bounds-check.patch Normal file
View File

@ -0,0 +1,319 @@
Fix CVE-2016-{9634,9635,9636}.
https://cve.mitre.org/cgi-bin/cvename.cgi?name=CVE-2016-9634
https://cve.mitre.org/cgi-bin/cvename.cgi?name=CVE-2016-9635
https://cve.mitre.org/cgi-bin/cvename.cgi?name=CVE-2016-9636
This fixes upstream bug #774834 (flic decoder: Buffer overflow in
flx_decode_delta_fli):
https://bugzilla.gnome.org/show_bug.cgi?id=774834
Patch copied from upstream source repository:
https://cgit.freedesktop.org/gstreamer/gst-plugins-good/commit/?id=2e203a79b7d9af4029307c1a845b3c148d5f5e62
From 2e203a79b7d9af4029307c1a845b3c148d5f5e62 Mon Sep 17 00:00:00 2001
From: Matthew Waters <matthew@centricular.com>
Date: Tue, 22 Nov 2016 19:05:00 +1100
Subject: [PATCH] flxdec: add some write bounds checking
Without checking the bounds of the frame we are writing into, we can
write off the end of the destination buffer.
https://scarybeastsecurity.blogspot.dk/2016/11/0day-exploit-advancing-exploitation.html
https://bugzilla.gnome.org/show_bug.cgi?id=774834
---
gst/flx/gstflxdec.c | 116 +++++++++++++++++++++++++++++++++++++++++-----------
1 file changed, 91 insertions(+), 25 deletions(-)
diff --git a/gst/flx/gstflxdec.c b/gst/flx/gstflxdec.c
index 604be2f..d51a8e6 100644
--- a/gst/flx/gstflxdec.c
+++ b/gst/flx/gstflxdec.c
@@ -74,9 +74,9 @@ static gboolean gst_flxdec_src_query_handler (GstPad * pad, GstObject * parent,
GstQuery * query);
static void flx_decode_color (GstFlxDec *, guchar *, guchar *, gint);
-static void flx_decode_brun (GstFlxDec *, guchar *, guchar *);
-static void flx_decode_delta_fli (GstFlxDec *, guchar *, guchar *);
-static void flx_decode_delta_flc (GstFlxDec *, guchar *, guchar *);
+static gboolean flx_decode_brun (GstFlxDec *, guchar *, guchar *);
+static gboolean flx_decode_delta_fli (GstFlxDec *, guchar *, guchar *);
+static gboolean flx_decode_delta_flc (GstFlxDec *, guchar *, guchar *);
#define rndalign(off) ((off) + ((off) & 1))
@@ -203,13 +203,14 @@ gst_flxdec_sink_event_handler (GstPad * pad, GstObject * parent,
return ret;
}
-static void
+static gboolean
flx_decode_chunks (GstFlxDec * flxdec, gulong count, guchar * data,
guchar * dest)
{
FlxFrameChunk *hdr;
+ gboolean ret = TRUE;
- g_return_if_fail (data != NULL);
+ g_return_val_if_fail (data != NULL, FALSE);
while (count--) {
hdr = (FlxFrameChunk *) data;
@@ -228,17 +229,17 @@ flx_decode_chunks (GstFlxDec * flxdec, gulong count, guchar * data,
break;
case FLX_BRUN:
- flx_decode_brun (flxdec, data, dest);
+ ret = flx_decode_brun (flxdec, data, dest);
data += rndalign (hdr->size) - FlxFrameChunkSize;
break;
case FLX_LC:
- flx_decode_delta_fli (flxdec, data, dest);
+ ret = flx_decode_delta_fli (flxdec, data, dest);
data += rndalign (hdr->size) - FlxFrameChunkSize;
break;
case FLX_SS2:
- flx_decode_delta_flc (flxdec, data, dest);
+ ret = flx_decode_delta_flc (flxdec, data, dest);
data += rndalign (hdr->size) - FlxFrameChunkSize;
break;
@@ -256,7 +257,12 @@ flx_decode_chunks (GstFlxDec * flxdec, gulong count, guchar * data,
data += rndalign (hdr->size) - FlxFrameChunkSize;
break;
}
+
+ if (!ret)
+ break;
}
+
+ return ret;
}
@@ -289,13 +295,13 @@ flx_decode_color (GstFlxDec * flxdec, guchar * data, guchar * dest, gint scale)
}
}
-static void
+static gboolean
flx_decode_brun (GstFlxDec * flxdec, guchar * data, guchar * dest)
{
gulong count, lines, row;
guchar x;
- g_return_if_fail (flxdec != NULL);
+ g_return_val_if_fail (flxdec != NULL, FALSE);
lines = flxdec->hdr.height;
while (lines--) {
@@ -313,12 +319,21 @@ flx_decode_brun (GstFlxDec * flxdec, guchar * data, guchar * dest)
if (count > 0x7f) {
/* literal run */
count = 0x100 - count;
+ if ((glong) row - count < 0) {
+ GST_ERROR_OBJECT (flxdec, "Invalid BRUN packet detected.");
+ return FALSE;
+ }
row -= count;
while (count--)
*dest++ = *data++;
} else {
+ if ((glong) row - count < 0) {
+ GST_ERROR_OBJECT (flxdec, "Invalid BRUN packet detected.");
+ return FALSE;
+ }
+
/* replicate run */
row -= count;
x = *data++;
@@ -328,22 +343,28 @@ flx_decode_brun (GstFlxDec * flxdec, guchar * data, guchar * dest)
}
}
}
+
+ return TRUE;
}
-static void
+static gboolean
flx_decode_delta_fli (GstFlxDec * flxdec, guchar * data, guchar * dest)
{
gulong count, packets, lines, start_line;
guchar *start_p, x;
- g_return_if_fail (flxdec != NULL);
- g_return_if_fail (flxdec->delta_data != NULL);
+ g_return_val_if_fail (flxdec != NULL, FALSE);
+ g_return_val_if_fail (flxdec->delta_data != NULL, FALSE);
/* use last frame for delta */
memcpy (dest, flxdec->delta_data, flxdec->size);
start_line = (data[0] + (data[1] << 8));
lines = (data[2] + (data[3] << 8));
+ if (start_line + lines > flxdec->hdr.height) {
+ GST_ERROR_OBJECT (flxdec, "Invalid FLI packet detected. too many lines.");
+ return FALSE;
+ }
data += 4;
/* start position of delta */
@@ -356,7 +377,8 @@ flx_decode_delta_fli (GstFlxDec * flxdec, guchar * data, guchar * dest)
while (packets--) {
/* skip count */
- dest += *data++;
+ guchar skip = *data++;
+ dest += skip;
/* RLE count */
count = *data++;
@@ -364,12 +386,24 @@ flx_decode_delta_fli (GstFlxDec * flxdec, guchar * data, guchar * dest)
if (count > 0x7f) {
/* literal run */
count = 0x100 - count;
- x = *data++;
+ if (skip + count > flxdec->hdr.width) {
+ GST_ERROR_OBJECT (flxdec, "Invalid FLI packet detected. "
+ "line too long.");
+ return FALSE;
+ }
+
+ x = *data++;
while (count--)
*dest++ = x;
} else {
+ if (skip + count > flxdec->hdr.width) {
+ GST_ERROR_OBJECT (flxdec, "Invalid FLI packet detected. "
+ "line too long.");
+ return FALSE;
+ }
+
/* replicate run */
while (count--)
*dest++ = *data++;
@@ -378,21 +412,27 @@ flx_decode_delta_fli (GstFlxDec * flxdec, guchar * data, guchar * dest)
start_p += flxdec->hdr.width;
dest = start_p;
}
+
+ return TRUE;
}
-static void
+static gboolean
flx_decode_delta_flc (GstFlxDec * flxdec, guchar * data, guchar * dest)
{
gulong count, lines, start_l, opcode;
guchar *start_p;
- g_return_if_fail (flxdec != NULL);
- g_return_if_fail (flxdec->delta_data != NULL);
+ g_return_val_if_fail (flxdec != NULL, FALSE);
+ g_return_val_if_fail (flxdec->delta_data != NULL, FALSE);
/* use last frame for delta */
memcpy (dest, flxdec->delta_data, flxdec->size);
lines = (data[0] + (data[1] << 8));
+ if (lines > flxdec->hdr.height) {
+ GST_ERROR_OBJECT (flxdec, "Invalid FLC packet detected. too many lines.");
+ return FALSE;
+ }
data += 2;
start_p = dest;
@@ -405,9 +445,15 @@ flx_decode_delta_flc (GstFlxDec * flxdec, guchar * data, guchar * dest)
while ((opcode = (data[0] + (data[1] << 8))) & 0xc000) {
data += 2;
if ((opcode & 0xc000) == 0xc000) {
- /* skip count */
- start_l += (0x10000 - opcode);
- dest += flxdec->hdr.width * (0x10000 - opcode);
+ /* line skip count */
+ gulong skip = (0x10000 - opcode);
+ if (skip > flxdec->hdr.height) {
+ GST_ERROR_OBJECT (flxdec, "Invalid FLC packet detected. "
+ "skip line count too big.");
+ return FALSE;
+ }
+ start_l += skip;
+ dest += flxdec->hdr.width * skip;
} else {
/* last pixel */
dest += flxdec->hdr.width;
@@ -419,7 +465,8 @@ flx_decode_delta_flc (GstFlxDec * flxdec, guchar * data, guchar * dest)
/* last opcode is the packet count */
while (opcode--) {
/* skip count */
- dest += *data++;
+ guchar skip = *data++;
+ dest += skip;
/* RLE count */
count = *data++;
@@ -427,12 +474,25 @@ flx_decode_delta_flc (GstFlxDec * flxdec, guchar * data, guchar * dest)
if (count > 0x7f) {
/* replicate word run */
count = 0x100 - count;
+
+ if (skip + count > flxdec->hdr.width) {
+ GST_ERROR_OBJECT (flxdec, "Invalid FLC packet detected. "
+ "line too long.");
+ return FALSE;
+ }
+
while (count--) {
*dest++ = data[0];
*dest++ = data[1];
}
data += 2;
} else {
+ if (skip + count > flxdec->hdr.width) {
+ GST_ERROR_OBJECT (flxdec, "Invalid FLC packet detected. "
+ "line too long.");
+ return FALSE;
+ }
+
/* literal word run */
while (count--) {
*dest++ = *data++;
@@ -442,6 +502,8 @@ flx_decode_delta_flc (GstFlxDec * flxdec, guchar * data, guchar * dest)
}
lines--;
}
+
+ return TRUE;
}
static GstFlowReturn
@@ -571,9 +633,13 @@ gst_flxdec_chain (GstPad * pad, GstObject * parent, GstBuffer * buf)
out = gst_buffer_new_and_alloc (flxdec->size * 4);
/* decode chunks */
- flx_decode_chunks (flxdec,
- ((FlxFrameType *) chunk)->chunks,
- chunk + FlxFrameTypeSize, flxdec->frame_data);
+ if (!flx_decode_chunks (flxdec,
+ ((FlxFrameType *) chunk)->chunks,
+ chunk + FlxFrameTypeSize, flxdec->frame_data)) {
+ GST_ELEMENT_ERROR (flxdec, STREAM, DECODE,
+ ("%s", "Could not decode chunk"), NULL);
+ return GST_FLOW_ERROR;
+ }
/* save copy of the current frame for possible delta. */
memcpy (flxdec->delta_data, flxdec->frame_data, flxdec->size);
--
2.10.2

50
gnu/packages/patches/ldc-disable-tests.patch
View File

@ -4,19 +4,9 @@ two others use networking. Not bad out of almost 700 tests!
by Pjotr Prins <pjotr.guix@thebird.nl>
diff --git a/std/datetime.d b/std/datetime.d
index 8e4ed3b..6c15bc5 100644
--- a/std/datetime.d
+++ b/std/datetime.d
@@ -28018,6 +28018,7 @@ public:
The default directory where the TZ Database files are. It's empty
for Windows, since Windows doesn't have them.
+/
+
enum defaultTZDatabaseDir = "/usr/share/zoneinfo/";
}
else version(Windows)
@@ -28069,14 +28070,13 @@ assert(tz.dstName == "PDT");
--- a/std/datetime.d.orig 2016-11-24 01:13:52.584495545 +0100
+++ b/std/datetime.d 2016-11-24 01:17:09.655306728 +0100
@@ -28081,22 +28081,24 @@
import std.range : retro;
import std.format : format;
@ -25,9 +15,20 @@ index 8e4ed3b..6c15bc5 100644
enforce(tzDatabaseDir.exists(), new DateTimeException(format("Directory %s does not exist.", tzDatabaseDir)));
enforce(tzDatabaseDir.isDir, new DateTimeException(format("%s is not a directory.", tzDatabaseDir)));
- immutable file = buildNormalizedPath(tzDatabaseDir, name);
+ auto filename = "./" ~ strip(name); // make sure the prefix is not stripped
+ immutable file = buildNormalizedPath(tzDatabaseDir, filename);
version(Android)
{
+ name = strip(name);
auto tzfileOffset = name in tzdataIndex(tzDatabaseDir);
enforce(tzfileOffset, new DateTimeException(format("The time zone %s is not listed.", name)));
string tzFilename = separate_index ? "zoneinfo.dat" : "tzdata";
immutable file = buildNormalizedPath(tzDatabaseDir, tzFilename);
}
else
- immutable file = buildNormalizedPath(tzDatabaseDir, name);
+ {
+ auto filename = "./" ~ strip(name); // make sure the prefix is not stripped
+ immutable file = buildNormalizedPath(tzDatabaseDir, filename);
+ }
- enforce(file.exists(), new DateTimeException(format("File %s does not exist.", file)));
+ enforce(file.exists(), new DateTimeException(format("File %s does not exist in %s.", file, tzDatabaseDir)));
@ -54,23 +55,6 @@ diff --git a/std/socket.d b/std/socket.d
index b85d1c9..7fbf346 100644
--- a/std/socket.d
+++ b/std/socket.d
@@ -517,6 +517,8 @@ class Protocol
unittest
{
+ pragma(msg, "test disabled on GNU Guix");
+/*
// getprotobyname,number are unimplemented on Android
softUnittest({
Protocol proto = new Protocol;
@@ -530,6 +532,7 @@ unittest
assert(proto.name == "tcp");
assert(proto.aliases.length == 1 && proto.aliases[0] == "TCP");
});
+*/
}
@@ -859,6 +862,8 @@ class InternetHost
unittest

14
gnu/packages/patches/python-rarfile-fix-tests.patch
View File

@ -1,14 +0,0 @@
There is no test.sh, but there are test1.sh and test2.sh.
diff --git a/test/Makefile b/test/Makefile
index 027bc5f..5383db3 100644
--- a/test/Makefile
+++ b/test/Makefile
@@ -1,5 +1,6 @@
test:
- ./test.sh
+ ./test1.sh
+ ./test2.sh
clean:
rm -rf __pycache__

11
gnu/packages/pdf.scm
View File

@ -95,6 +95,17 @@
;; To build poppler-glib (as needed by Evince), we need Cairo and
;; GLib. But of course, that Cairo must not depend on Poppler.
("cairo" ,(package (inherit cairo)
(replacement
(package
(inherit cairo)
(replacement #f)
(source
(origin
(inherit (package-source cairo))
(patches (search-patches
"cairo-CVE-2016-9082.patch"))))
(inputs (alist-delete "poppler"
(package-inputs cairo)))))
(inputs (alist-delete "poppler"
(package-inputs cairo)))))
("glib" ,glib)))

47
gnu/packages/perl-web.scm Normal file
View File

@ -0,0 +1,47 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; 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 perl-web)
#:use-module ((guix licenses) #:prefix license:)
#:use-module (gnu packages)
#:use-module (guix packages)
#:use-module (guix download)
#:use-module (guix build-system perl))
(define-public perl-mojolicious
(package
(name "perl-mojolicious")
(version "7.10")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://cpan/authors/id/S/SR/SRI/Mojolicious-"
version ".tar.gz"))
(sha256
(base32
"0811f3wajgf71y02dr2khqnaswjh582pcvhv93k101qpg61syihn"))))
(build-system perl-build-system)
(home-page "http://mojolicious.org/")
(synopsis "Real-time web framework")
(description "Back in the early days of the web, many people learned Perl
because of a wonderful Perl library called @code{CGI}. It was simple enough
to get started without knowing much about the language and powerful enough to
keep you going, learning by doing was much fun. While most of the techniques
used are outdated now, the idea behind it is not. Mojolicious is a new
endeavor to implement this idea using modern technologies.")
(license license:artistic2.0)))

513
gnu/packages/perl.scm
View File

@ -34,7 +34,8 @@
#:use-module (guix packages)
#:use-module (guix download)
#:use-module (guix build-system gnu)
#:use-module (guix build-system perl))
#:use-module (guix build-system perl)
#:use-module (gnu packages perl-web))
;;;
;;; Please: Try to add new module packages in alphabetic order.
@ -266,6 +267,33 @@ manipulate, read, and write Zip archive files.")
list manipulation routines.")
(license (package-license perl))))
(define-public perl-autovivification
(package
(name "perl-autovivification")
(version "0.16")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://cpan/authors/id/V/VP/VPIT/"
"autovivification-" version ".tar.gz"))
(sha256
(base32
"1422kw9fknv7rbjkgdfflg1q3mb69d3yryszp38dn0bgzkqhwkc1"))))
(build-system perl-build-system)
(home-page "http://search.cpan.org/dist/autovivification")
(synopsis "Lexically disable autovivification")
(description "When an undefined variable is dereferenced, it gets silently
upgraded to an array or hash reference (depending of the type of the
dereferencing). This behaviour is called autovivification and usually does
what you mean but it may be unnatural or surprising because your variables get
populated behind your back. This is especially true when several levels of
dereferencing are involved, in which case all levels are vivified up to the
last, or when it happens in intuitively read-only constructs like
@code{exists}. The pragma provided by this package lets you disable
autovivification for some constructs and optionally throws a warning or an
error when it would have happened.")
(license (package-license perl))))
(define-public perl-base
(package
(name "perl-base")
@ -380,6 +408,88 @@ library can nevertheless be used stand-alone, without Perl.")
special objects: true and false.")
(license (package-license perl))))
(define-public perl-business-isbn-data
(package
(name "perl-business-isbn-data")
(version "20140910.003")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://cpan/authors/id/B/BD/BDFOY/"
"Business-ISBN-Data-" version ".tar.gz"))
(sha256
(base32
"1jc5jrjwkr6pqga7998zkgw0yrxgb5n1y7lzgddawxibkf608mn7"))))
(build-system perl-build-system)
(home-page "http://search.cpan.org/dist/Business-ISBN-Data")
(synopsis "Data files for Business::ISBN")
(description "This package provides a data pack for @code{Business::ISBN}.
These data are generated from the RangeMessage.xml file provided by the ISBN
Agency.")
(license (package-license perl))))
(define-public perl-business-isbn
(package
(name "perl-business-isbn")
(version "3.003")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://cpan/authors/id/B/BD/BDFOY/"
"Business-ISBN-" version ".tar.gz"))
(sha256
(base32
"1i2bxzqkki257rqbswa4ryj1grmwa5s47wrxln2ff5mha1ry31gm"))))
(build-system perl-build-system)
(propagated-inputs
`(("perl-business-isbn-data" ,perl-business-isbn-data)
("perl-mojolicious" ,perl-mojolicious)))
(home-page "http://search.cpan.org/dist/Business-ISBN")
(synopsis "Work with International Standard Book Numbers")
(description "This modules provides tools to deal with International
Standard Book Numbers, including ISBN-10 and ISBN-13.")
(license artistic2.0)))
(define-public perl-business-issn
(package
(name "perl-business-issn")
(version "0.91")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://cpan/authors/id/B/BD/BDFOY/"
"Business-ISSN-" version ".tar.gz"))
(sha256
(base32
"1dfnm7h7lbqj356700ldlmgbr51v6hyjn1qig2bb4ysl1wn1jnzi"))))
(build-system perl-build-system)
(home-page "http://search.cpan.org/dist/Business-ISSN")
(synopsis "Work with International Standard Serial Numbers")
(description "This modules provides tools to deal with International
Standard Serial Numbers.")
(license (package-license perl))))
(define-public perl-business-ismn
(package
(name "perl-business-ismn")
(version "1.13")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://cpan/authors/id/B/BD/BDFOY/"
"Business-ISMN-" version ".tar.gz"))
(sha256
(base32
"0cm1v75axg4gp6cnbyavmnqqjscsxh7nc60vcbw34rqivvf9idc9"))))
(build-system perl-build-system)
(native-inputs
`(("perl-tie-cycle" ,perl-tie-cycle)))
(home-page "http://search.cpan.org/dist/Business-ISMN")
(synopsis "Work with International Standard Music Numbers")
(description "This modules provides tools to deal with International
Standard Music Numbers.")
(license (package-license perl))))
(define-public perl-cache-cache
(package
(name "perl-cache-cache")
@ -1200,6 +1310,47 @@ functions and data structures for processing and analysing genomic and
bioinformatics data.")
(license gpl3+)))
(define-public perl-data-compare
(package
(name "perl-data-compare")
(version "1.25")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://cpan/authors/id/D/DC/DCANTRELL/"
"Data-Compare-" version ".tar.gz"))
(sha256
(base32
"0wzasidg9yjcfsi2gdiaw6726ikqda7n24n0v2ngpaazakdkcjqx"))))
(build-system perl-build-system)
(propagated-inputs
`(("perl-file-find-rule" ,perl-file-find-rule)))
(home-page "http://search.cpan.org/dist/Data-Compare")
(synopsis "Compare Perl data structures")
(description "This module compares arbitrary data structures to see if
they are copies of each other.")
(license (package-license perl))))
(define-public perl-data-uniqid
(package
(name "perl-data-uniqid")
(version "0.12")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://cpan/authors/id/M/MW/MWX/Data-Uniqid-"
version ".tar.gz"))
(sha256
(base32
"1jsc6acmv97pzsvx1fqywz4qvxxpp7kwmb78ygyqpsczkfj9p4dn"))))
(build-system perl-build-system)
(home-page "http://search.cpan.org/dist/Data-Uniqid")
(synopsis "Perl extension for generating unique identifiers")
(description "@code{Data::Uniqid} provides three simple routines for
generating unique ids. These ids are coded with a Base62 systen to make them
short and handy (e.g. to use it as part of a URL).")
(license (package-license perl))))
(define-public perl-data-dump
(package
(name "perl-data-dump")
@ -1468,6 +1619,28 @@ operations, such as comparing two times, determining a date a given amount of
time from another, or parsing international times.")
(license (package-license perl))))
(define-public perl-date-simple
(package
(name "perl-date-simple")
(version "3.03")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://cpan/authors/id/I/IZ/IZUT/"
"Date-Simple-" version ".tar.gz"))
(sha256
(base32
"016x17r9wi6ffdc4idwirzd1sxqcb4lmq5fn2aiq25nf2iir5899"))))
(build-system perl-build-system)
(home-page "http://search.cpan.org/dist/Date-Simple")
(synopsis "Simple date handling")
(description "Dates are complex enough without times and timezones. This
module may be used to create simple date objects. It handles validation,
interval arithmetic, and day-of-week calculation. It does not deal with
hours, minutes, seconds, and time zones.")
;; Can be used with either license.
(license (list (package-license perl) gpl2+))))
(define-public perl-datetime
(package
(name "perl-datetime")
@ -1497,6 +1670,30 @@ combinations. It represents the Gregorian calendar, extended backwards in
time before its creation (in 1582).")
(license artistic2.0)))
(define-public perl-datetime-calendar-julian
(package
(name "perl-datetime-calendar-julian")
(version "0.04")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://cpan/authors/id/P/PI/PIJLL/"
"DateTime-Calendar-Julian-" version ".tar.gz"))
(sha256
(base32
"03h0llkwsiw2d2ci1ah5x9sp8xrvnbgd471i5hnpgl5w32nnhndv"))))
(build-system perl-build-system)
;; Only needed for tests
(native-inputs
`(("perl-datetime" ,perl-datetime)))
(home-page "http://search.cpan.org/dist/DateTime-Calendar-Julian")
(synopsis "Dates in the Julian calendar")
(description "This package is a companion module to @code{DateTime.pm}.
It implements the Julian calendar. It supports everything that
@code{DateTime.pm} supports and more: about one day per century more, to be
precise.")
(license (package-license perl))))
(define-public perl-datetime-set
(package
(name "perl-datetime-set")
@ -2125,6 +2322,86 @@ SHA-1 message digest algorithm for use by Perl programs.")
modules separately and deal with them after the module is done installing.")
(license (package-license perl))))
(define-public perl-encode-detect
(package
(name "perl-encode-detect")
(version "1.01")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://cpan/authors/id/J/JG/JGMYERS/"
"Encode-Detect-" version ".tar.gz"))
(sha256
(base32
"1wdv9ffgs4xyfh5dnh09dqkmmlbf5m1hxgdgb3qy6v6vlwx8jkc3"))))
(build-system perl-build-system)
(native-inputs
`(("perl-module-build" ,perl-module-build)))
(home-page "http://search.cpan.org/dist/Encode-Detect")
(synopsis "Detect the encoding of data")
(description "This package provides a class @code{Encode::Detect} to detect
the encoding of data.")
(license mpl1.1)))
(define-public perl-encode-eucjpascii
(package
(name "perl-encode-eucjpascii")
(version "0.03")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://cpan/authors/id/N/NE/NEZUMI/"
"Encode-EUCJPASCII-" version ".tar.gz"))
(sha256
(base32
"0qg8kmi7r9jcf8326b4fyq5sdpqyim2a11h7j77q577xam6x767r"))))
(build-system perl-build-system)
(home-page "http://search.cpan.org/dist/Encode-EUCJPASCII")
(synopsis "ASCII mapping for eucJP encoding")
(description "This package provides an ASCII mapping for the eucJP
encoding.")
(license (package-license perl))))
(define-public perl-encode-jis2k
(package
(name "perl-encode-jis2k")
(version "0.03")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://cpan/authors/id/D/DA/DANKOGAI/"
"Encode-JIS2K-" version ".tar.gz"))
(sha256
(base32
"1k1mdj4rd9m1z4h7qd2dl92ky0r1rk7mmagwsvdb9pirvdr4vj0y"))))
(build-system perl-build-system)
(home-page "http://search.cpan.org/dist/Encode-JIS2K")
(synopsis "JIS X 0212 (aka JIS 2000) encodings")
(description "This package provides encodings for JIS X 0212, which is
also known as JIS 2000.")
(license (package-license perl))))
(define-public perl-encode-hanextra
(package
(name "perl-encode-hanextra")
(version "0.23")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://cpan/authors/id/A/AU/AUDREYT/"
"Encode-HanExtra-" version ".tar.gz"))
(sha256
(base32
"0fj4vd8iva2i0j6s2fyhwgr9afrvhr6gjlzi7805h257mmnb1m0z"))))
(build-system perl-build-system)
(home-page "http://search.cpan.org/dist/Encode-HanExtra")
(synopsis "Additional Chinese encodings")
(description "This Perl module provides Chinese encodings that are not
part of Perl by default, including \"BIG5-1984\", \"BIG5-2003\", \"BIG5PLUS\",
\"BIG5EXT\", \"CCCII\", \"EUC-TW\", \"CNS11643-*\", \"GB18030\", and
\"UNISYS\".")
(license expat)))
(define-public perl-env-path
(package
(name "perl-env-path")
@ -2325,6 +2602,29 @@ it ties together a family of modern toolchain modules.")
module building modules.")
(license (package-license perl))))
(define-public perl-extutils-libbuilder
(package
(name "perl-extutils-libbuilder")
(version "0.08")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://cpan/authors/id/A/AM/AMBS/"
"ExtUtils-LibBuilder-" version ".tar.gz"))
(sha256
(base32
"1lmmfcjxvsvhn4f3v2lyylgr8dzcf5j7mnd1pkq3jc75dph724f5"))))
(build-system perl-build-system)
(native-inputs
`(("perl-module-build" ,perl-module-build)))
(home-page "http://search.cpan.org/dist/ExtUtils-LibBuilder")
(synopsis "Tool to build C libraries")
(description "Some Perl modules need to ship C libraries together with
their Perl code. Although there are mechanisms to compile and link (or glue)
C code in your Perl programs, there isn't a clear method to compile standard,
self-contained C libraries. This module main goal is to help in that task.")
(license (package-license perl))))
(define-public perl-file-changenotify
(package
(name "perl-file-changenotify")
@ -3023,6 +3323,26 @@ filehandles; in particular, IO::Scalar, IO::ScalarArray, and IO::Lines.")
pseudo ttys.")
(license (package-license perl))))
(define-public perl-ipc-cmd
(package
(name "perl-ipc-cmd")
(version "0.96")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://cpan/authors/id/B/BI/BINGOS/IPC-Cmd-"
version ".tar.gz"))
(sha256
(base32
"0a2v44x70gj9fd5wa8i08f9z6n14qppj1j49m1hc333wh72mzk6i"))))
(build-system perl-build-system)
(home-page "http://search.cpan.org/dist/IPC-Cmd")
(synopsis "Run interactive command-line programs")
(description "@code{IPC::Cmd} allows for the searching and execution of
any binary on your system. It adheres to verbosity settings and is able to
run interactively. It also has an option to capture output/error buffers.")
(license (package-license perl))))
(define-public perl-ipc-run
(package
(name "perl-ipc-run")
@ -3345,6 +3665,26 @@ version.")
one: logging, exceptions, and translations.")
(license (package-license perl))))
(define-public perl-lingua-translit
(package
(name "perl-lingua-translit")
(version "0.26")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://cpan/authors/id/A/AL/ALINKE/"
"Lingua-Translit-" version ".tar.gz"))
(sha256
(base32
"161589h08kzliga17i2g0hb0yn4cjmb8rdiyadq5bw97974bac14"))))
(build-system perl-build-system)
(home-page "http://search.cpan.org/dist/Lingua-Translit")
(synopsis "Transliterate text between writing systems")
(description "@code{Lingua::Translit} can be used to convert text from one
writing system to another, based on national or international transliteration
tables. Where possible a reverse transliteration is supported.")
(license (package-license perl))))
(define-public perl-list-allutils
(package
(name "perl-list-allutils")
@ -4372,6 +4712,26 @@ own set of Moose-like types. These custom types can then be used to describe
fields in Moo-based classes.")
(license (package-license perl))))
(define-public perl-mozilla-ca
(package
(name "perl-mozilla-ca")
(version "20160104")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://cpan/authors/id/A/AB/ABH/Mozilla-CA-"
version ".tar.gz"))
(sha256
(base32
"0aizn08lrdrgjz9vagkjmw2c7sxn46fzz521v9dbcqii4jd0d9r7"))))
(build-system perl-build-system)
(home-page "http://search.cpan.org/dist/Mozilla-CA")
(synopsis "Mozilla's CA cert bundle in PEM format")
(description "@code{Mozilla::CA} provides a copy of Mozilla's bundle of
Certificate Authority certificates in a form that can be consumed by modules
and libraries based on OpenSSL.")
(license mpl2.0)))
(define-public perl-mro-compat
(package
(name "perl-mro-compat")
@ -5045,6 +5405,25 @@ designed to be slow or big, neither has it been designed to be fast or
compact.")
(license (package-license perl))))
(define-public perl-sort-key
(package
(name "perl-sort-key")
(version "1.33")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://cpan/authors/id/S/SA/SALVA/Sort-Key-"
version ".tar.gz"))
(sha256
(base32
"1kqs10s2plj6c96srk0j8d7xj8dxk1704r7mck8rqk09mg7lqspd"))))
(build-system perl-build-system)
(home-page "http://search.cpan.org/dist/Sort-Key")
(synopsis "Sort arrays by one or multiple calculated keys")
(description "This Perl module provides various functions to quickly sort
arrays by one or multiple calculated keys.")
(license (package-license perl))))
(define-public perl-spiffy
(package
(name "perl-spiffy")
@ -6389,6 +6768,29 @@ decomposition of comma-separated values. An instance of the Text::CSV class
can combine fields into a CSV string and parse a CSV string into fields.")
(license (package-license perl))))
(define-public perl-text-csv-xs
(package
(name "perl-text-csv-xs")
(version "1.25")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://cpan/authors/id/H/HM/HMBRAND/"
"Text-CSV_XS-" version ".tgz"))
(sha256
(base32
"06zlfbqrwbl0g2g3bhk6046yy5pf2rz80fzcp8aj47rnswz2yx5k"))))
(build-system perl-build-system)
(home-page "http://search.cpan.org/dist/Text-CSV_XS")
(synopsis "Rountines for manipulating CSV files")
(description "@code{Text::CSV_XS} provides facilities for the composition
and decomposition of comma-separated values. An instance of the
@code{Text::CSV_XS} class will combine fields into a CSV string and parse a
CSV string into fields. The module accepts either strings or files as input
and support the use of user-specified characters for delimiters, separators,
and escapes.")
(license (package-license perl))))
(define-public perl-text-diff
(package
(name "perl-text-diff")
@ -6459,6 +6861,27 @@ template engine, for when you need speed rather than complex features,
yet need more features than simple variable substitution.")
(license (package-license perl))))
(define-public perl-text-roman
(package
(name "perl-text-roman")
(version "3.5")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://cpan/authors/id/S/SY/SYP/Text-Roman-"
version ".tar.gz"))
(sha256
(base32
"0sh47svzz0wm993ywfgpn0fvhajl2sj5hcnf5zxjz02in6ihhjnb"))))
(build-system perl-build-system)
(home-page "http://search.cpan.org/dist/Text-Roman")
(synopsis "Convert between Roman and Arabic algorisms")
(description "This package provides functions to convert between Roman and
Arabic algorisms. It supports both conventional Roman algorisms (which range
from 1 to 3999) and Milhar Romans, a variation which uses a bar across the
algorism to indicate multiplication by 1000.")
(license (package-license perl))))
(define-public perl-text-simpletable
(package
(name "perl-text-simpletable")
@ -6567,6 +6990,25 @@ controlled with command line parameters. The default parameter settings
approximately follow the suggestions in the Perl Style Guide.")
(license gpl2+)))
(define-public perl-tie-cycle
(package
(name "perl-tie-cycle")
(version "1.221")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://cpan/authors/id/B/BD/BDFOY/Tie-Cycle-"
version ".tar.gz"))
(sha256
(base32
"10g6kirf6jfaldckg98y4pl87vrm7grqlg6ymb7a9vhrznyn7qn6"))))
(build-system perl-build-system)
(home-page "http://search.cpan.org/dist/Tie-Cycle")
(synopsis "Cycle through a list of values")
(description "You use @code{Tie::Cycle} to go through a list over and over
again. Once you get to the end of the list, you go back to the beginning.")
(license (package-license perl))))
(define-public perl-tie-ixhash
(package
(name "perl-tie-ixhash")
@ -6810,17 +7252,58 @@ else.")
common serialisation formats such as JSON or CBOR.")
(license (package-license perl))))
(define-public perl-unicode-normalize
(package
(name "perl-unicode-normalize")
(version "1.25")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://cpan/authors/id/K/KH/KHW/"
"Unicode-Normalize-" version ".tar.gz"))
(sha256
(base32
"0v04bcyjfcfap4kfpc8q3ikq3j7s68nym4ckw3iasmmksdskmcq0"))))
(build-system perl-build-system)
(home-page "http://search.cpan.org/dist/Unicode-Normalize")
(synopsis "Unicode normalization forms")
(description "This Perl module provides Unicode normalization forms.")
(license (package-license perl))))
(define-public perl-unicode-collate
(package
(name "perl-unicode-collate")
(version "1.18")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://cpan/authors/id/S/SA/SADAHIRO/"
"Unicode-Collate-" version ".tar.gz"))
(sha256
(base32
"1lq4p3mqqljhhy8wyiyahris33j4m5qfzpi6iacmcqjzw5g4afbm"))))
(build-system perl-build-system)
(propagated-inputs
`(("perl-unicode-normalize" ,perl-unicode-normalize)))
(home-page "http://search.cpan.org/dist/Unicode-Collate")
(synopsis "Unicode collation algorithm")
(description "This package provides tools for sorting and comparing
Unicode data.")
;; The file Unicode/Collate/allkeys.txt is released under the Expat
;; license.
(license (list (package-license perl) expat))))
(define-public perl-unicode-linebreak
(package
(name "perl-unicode-linebreak")
(version "2015.12")
(version "2016.003")
(source (origin
(method url-fetch)
(uri (string-append "mirror://cpan/authors/id/N/NE/NEZUMI/"
"Unicode-LineBreak-" version ".tar.gz"))
(sha256
(base32
"1d0nnc97irfpab4d3b2lvq22hac118k7zbfrj0lnxkbfwx7122cm"))))
"096wf5x99swx7l7yd8pm2aw50g596nf50rkq7250zjcc1acjskp6"))))
(build-system perl-build-system)
(propagated-inputs
`(("perl-mime-charset" ,perl-mime-charset)))
@ -7268,27 +7751,3 @@ interface to File::Find::Object.")
(description "Test::TrailingSpace tests for trailing spaces
in Perl source files.")
(license x11)))
(define-public perl-encode-detect
(package
(name "perl-encode-detect")
(version "1.01")
(source
(origin
(method url-fetch)
(uri (string-append
"mirror://cpan/authors/id/J/JG/JGMYERS/Encode-Detect-"
version
".tar.gz"))
(sha256
(base32
"1wdv9ffgs4xyfh5dnh09dqkmmlbf5m1hxgdgb3qy6v6vlwx8jkc3"))))
(build-system perl-build-system)
(inputs
`(("perl-module-build" ,perl-module-build)))
(home-page
"http://search.cpan.org/dist/Encode-Detect")
(synopsis
"Perl Encode::Encoding subclass that detects the encoding of data")
(description "Encode::Detect detects the encoding of data for Perl.")
(license mpl1.1)))

11
gnu/packages/photo.scm
View File

@ -89,20 +89,21 @@ data as produced by digital cameras.")
(define-public libgphoto2
(package
(name "libgphoto2")
(version "2.5.2")
(version "2.5.11")
(source (origin
(method url-fetch)
(uri (string-append "mirror://sourceforge/gphoto/libgphoto/"
version "/libgphoto2-" version ".tar.bz2"))
(sha256
(base32
"0f1818l1vs5fbmrihzyv3qasddbqi3r01jik5crrxddwalsi2bd3"))))
"1ap070zz6l4kn2mbyxb1yj4x5ar8hpdbmf2pvjxgnly1ss319dkz"))))
(build-system gnu-build-system)
(native-inputs `(("pkg-config" ,pkg-config)))
(inputs
`(;; ("libjpeg-turbo" ,libjpeg-turbo)
("libltdl" ,libltdl)
("libusb" ,libusb)))
("libusb" ,libusb)
("libxml2" ,libxml2)))
(propagated-inputs
`(;; The .pc refers to libexif.
("libexif" ,libexif)))
@ -119,14 +120,14 @@ from digital cameras.")
(define-public gphoto2
(package
(name "gphoto2")
(version "2.5.2")
(version "2.5.11")
(source (origin
(method url-fetch)
(uri (string-append "mirror://sourceforge/gphoto/gphoto/" version
"/gphoto2-" version ".tar.bz2"))
(sha256
(base32
"16c8k1cxfypg7v5h8xi87grclw7a5ayaamn548ys3zkj727r5fcf"))))
"1sgr6rsvzzagcwhc8fxbnvz3k02wr2hab0vrbvcb04k5l3b48a1r"))))
(build-system gnu-build-system)
(native-inputs
`(("pkg-config" ,pkg-config)))

227
gnu/packages/psyc.scm
View File

@ -1,227 +0,0 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 ng0 <ngillmann@runbox.com>
;;;
;;; 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 psyc)
#:use-module (guix download)
#:use-module (guix git-download)
#:use-module ((guix licenses) #:prefix license:)
#:use-module (guix packages)
#:use-module (guix build-system perl)
#:use-module (guix build-system gnu)
#:use-module (gnu packages)
#:use-module (gnu packages admin)
#:use-module (gnu packages autotools)
#:use-module (gnu packages bison)
#:use-module (gnu packages compression)
#:use-module (gnu packages gettext)
#:use-module (gnu packages linux)
#:use-module (gnu packages man)
#:use-module (gnu packages ncurses)
#:use-module (gnu packages perl)
#:use-module (gnu packages pcre)
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages tls)
#:use-module (gnu packages web))
(define-public perl-net-psyc
(package
(name "perl-net-psyc")
(version "1.1")
(source
(origin
(method url-fetch)
(uri (string-append "http://perlpsyc.psyc.eu/"
"perlpsyc-" version ".zip"))
(file-name (string-append name "-" version ".zip"))
(sha256
(base32
"1lw6807qrbmvzbrjn1rna1dhir2k70xpcjvyjn45y35hav333a42"))
;; psycmp3 currently depends on MP3::List and rxaudio (shareware),
;; we can add it back when this is no longer the case.
(snippet '(delete-file "contrib/psycmp3"))))
(build-system perl-build-system)
(inputs
`(("perl-curses" ,perl-curses)
("perl-io-socket-ssl" ,perl-io-socket-ssl)))
(arguments
`(#:phases
(modify-phases %standard-phases
(delete 'configure) ; No configure script
;; There is a Makefile, but it does not install everything
;; (leaves out psycion) and says
;; "# Just to give you a rough idea". XXX: Fix it upstream.
(replace 'build
(lambda _
(zero? (system* "make" "manuals"))))
(replace 'install
(lambda* (#:key outputs #:allow-other-keys)
(let* ((out (assoc-ref outputs "out"))
(doc (string-append out "/share/doc/perl-net-psyc"))
(man1 (string-append out "/share/man/man1"))
(man3 (string-append out "/share/man/man3"))
(bin (string-append out "/bin"))
(libpsyc (string-append out "/lib/psyc/ion"))
(libperl (string-append out "/lib/perl5/site_perl/"
,(package-version perl))))
(copy-recursively "lib/perl5" libperl)
(copy-recursively "lib/psycion" libpsyc)
(copy-recursively "bin" bin)
(install-file "cgi/psycpager" (string-append doc "/cgi"))
(copy-recursively "contrib" (string-append doc "/contrib"))
(copy-recursively "hooks" (string-append doc "/hooks"))
(copy-recursively "sdj" (string-append doc "/sdj"))
(install-file "README.txt" doc)
(install-file "TODO.txt" doc)
(copy-recursively "share/man/man1" man1)
(copy-recursively "share/man/man3" man3)
#t)))
(add-after 'install 'wrap-programs
(lambda* (#:key outputs #:allow-other-keys)
;; Make sure all executables in "bin" find the Perl modules
;; provided by this package at runtime.
(let* ((out (assoc-ref outputs "out"))
(bin (string-append out "/bin/"))
(path (getenv "PERL5LIB")))
(for-each (lambda (file)
(wrap-program file
`("PERL5LIB" ":" prefix (,path))))
(find-files bin "\\.*$"))
#t))))))
(description
"@code{Net::PSYC} with support for TCP, UDP, Event.pm, @code{IO::Select} and
Gtk2 event loops. This package includes 12 applications and additional scripts:
psycion (a @uref{http://about.psyc.eu,PSYC} chat client), remotor (a control console
for @uref{https://torproject.org,tor} router) and many more.")
(synopsis "Perl implementation of PSYC protocol")
(home-page "http://perlpsyc.psyc.eu/")
(license (list license:gpl2
(package-license perl)
;; contrib/irssi-psyc.pl:
license:public-domain
;; bin/psycplay states AGPL with no version:
license:agpl3+))))
(define-public libpsyc
(package
(name "libpsyc")
(version "20160913")
(source (origin
(method url-fetch)
(uri (string-append "http://www.psyced.org/files/"
name "-" version ".tar.xz"))
(sha256
(base32
"14q89fxap05ajkfn20rnhc6b1h4i3i2adyr7y6hs5zqwb2lcmc1p"))))
(build-system gnu-build-system)
(native-inputs
`(("perl" ,perl)
("netcat" ,netcat)
("procps" ,procps)))
(arguments
`(#:make-flags
(list "CC=gcc"
(string-append "PREFIX=" (assoc-ref %outputs "out")))
#:phases
(modify-phases %standard-phases
;; The rust bindings are the only ones in use, the lpc bindings
;; are in psyclpc. The other bindings are not used by anything,
;; the chances are high that the bindings do not even work,
;; therefore we do not include them.
;; TODO: Get a cargo build system in Guix.
(delete 'configure)))) ; no configure script
(home-page "http://about.psyc.eu/libpsyc")
(description
"@code{libpsyc} is a PSYC library in C which implements
core aspects of PSYC, useful for all kinds of clients and servers
including psyced.")
(synopsis "PSYC library in C")
(license license:agpl3+)))
;; This commit removes the historic bundled pcre, not released as a tarball so far.
(define-public psyclpc
(let* ((commit "8bd51f2a4847860ba8b82dc79348ab37d516011e")
(revision "1"))
(package
(name "psyclpc")
(version (string-append "20160821-" revision "." (string-take commit 7)))
(source (origin
(method git-fetch)
(uri (git-reference
(url "git://git.psyced.org/git/psyclpc")
(commit commit)))
(file-name (string-append name "-" version "-checkout"))
(sha256
(base32
"10w4kx9ygcv1lcmd7j4knvjiy8dac1y3hjfv3lhp67jpv6w3iagz"))))
(build-system gnu-build-system)
(arguments
`(#:tests? #f ; There are no tests/checks.
#:configure-flags
;; If you have questions about this part, look at
;; "src/settings/psyced" and the ebuild.
(list
"--enable-use-tls=yes"
"--enable-use-mccp" ; Mud Client Compression Protocol, leave this enabled.
(string-append "--prefix="
(assoc-ref %outputs "out"))
;; src/Makefile: Set MUD_LIB to the directory which contains
;; the mud data. defaults to MUD_LIB = @libdir@
(string-append "--libdir="
(assoc-ref %outputs "out")
"/opt/psyced/world")
(string-append "--bindir="
(assoc-ref %outputs "out")
"/opt/psyced/bin")
;; src/Makefile: Set ERQ_DIR to directory which contains the
;; stuff which ERQ can execute (hopefully) savely. Was formerly
;; defined in config.h. defaults to ERQ_DIR= @libexecdir@
(string-append "--libexecdir="
(assoc-ref %outputs "out")
"/opt/psyced/run"))
#:phases
(modify-phases %standard-phases
(add-before 'configure 'chdir-to-src
;; We need to pass this as env variables
;; and manually change the directory.
(lambda _
(chdir "src")
(setenv "CONFIG_SHELL" (which "sh"))
(setenv "SHELL" (which "sh"))
#t)))
#:make-flags (list "install-all")))
(inputs
`(("zlib" ,zlib)
("openssl" ,openssl)
("pcre" ,pcre)))
(native-inputs
`(("pkg-config" ,pkg-config)
("bison" ,bison)
("gettext" ,gettext-minimal)
("help2man" ,help2man)
("autoconf" ,autoconf)
("automake" ,automake)))
(home-page "http://lpc.psyc.eu/")
(synopsis "psycLPC is a multi-user network server programming language")
(description
"LPC is a bytecode language, invented to specifically implement
multi user virtual environments on the internet. This technology is used for
MUDs and also the psyced implementation of the Protocol for SYnchronous
Conferencing (PSYC). psycLPC is a fork of LDMud with some new features and
many bug fixes.")
(license license:gpl2))))

54
gnu/packages/python.scm
View File

@ -31,6 +31,7 @@
;;; Copyright © 2016 Dylan Jeffers <sapientech@sapientech@openmailbox.org>
;;; Copyright © 2016 Alex Vong <alexvong1995@gmail.com>
;;; Copyright © 2016 Arun Isaac <arunisaac@systemreboot.net>
;;; Copyright © 2016 Julien Lepiller <julien@lepiller.eu>
;;;
;;; This file is part of GNU Guix.
;;;
@ -1145,14 +1146,14 @@ after Andy Lester’s Perl module WWW::Mechanize.")
(define-public python-simplejson
(package
(name "python-simplejson")
(version "3.8.2")
(version "3.10.0")
(source
(origin
(method url-fetch)
(uri (pypi-uri "simplejson" version))
(sha256
(base32
"0zylrnax8b6r0ndgni4w9c599fi6wm9vx5g6k3ddqfj3932kk16m"))))
"1qhwsykjlb85igb4cfl6v6gkprzbbg8gyqdd7zscc8w3x0ifcfwm"))))
(build-system python-build-system)
(home-page "http://simplejson.readthedocs.org/en/latest/")
(synopsis
@ -1387,6 +1388,31 @@ backported for previous versions of Python from 2.4 to 3.3.")
syntax.")
(license license:x11)))
(define-public python-polib
(package
(name "python-polib")
(version "1.0.8")
(source (origin
(method url-fetch)
(uri (pypi-uri "polib" version))
(sha256
(base32
"1pq2hbm3m2q0cjdszk8mc4qa1vl3wcblh5nfyirlfnzb2pcy7zss"))))
(build-system python-build-system)
(home-page "https://bitbucket.org/izi/polib/wiki/Home")
(synopsis "Manipulate, create and modify gettext files")
(description "Polib can manipulate any gettext format (po, pot and mo)
files. It can be used to create po files from scratch or to modify
existing ones.")
(license license:expat)))
(define-public python2-polib
(let ((base (package-with-python2 (strip-python2-variant python-polib))))
(package
(inherit base)
(arguments `(,@(package-arguments base)
;; Tests don't work with python2.
#:tests? #f)))))
(define-public scons
(package
@ -6432,14 +6458,14 @@ message digests and key derivation functions.")
(define-public python-pyopenssl
(package
(name "python-pyopenssl")
(version "16.1.0")
(version "16.2.0")
(source
(origin
(method url-fetch)
(uri (pypi-uri "pyOpenSSL" version))
(sha256
(base32
"0prm06zz7hl6bk5s2lqzw25lq6smayfv2fgiliw2rbqxlyiavxw8"))))
"0vji4yrfshs15xpczbhzhasnjrwcarsqg87n98ixnyafnyxs6ybp"))))
(build-system python-build-system)
(propagated-inputs
`(("python-cryptography" ,python-cryptography)
@ -9092,13 +9118,13 @@ way.")
(define-public python-munkres
(package
(name "python-munkres")
(version "1.0.7")
(version "1.0.8")
(source (origin
(method url-fetch)
(uri (pypi-uri "munkres" version))
(sha256
(base32
"1i6nf45i0kkzdx6k70giybsqxz4dxsjbrkrfqgjd7znfkf25sjik"))))
"0mbspx4zv8id4x6pim6ybsa1xh96qwpbqj7skbqz4c9c9nf1lpqq"))))
(build-system python-build-system)
(arguments
'(#:tests? #f)) ; no test suite
@ -9115,18 +9141,20 @@ useful for solving the Assignment Problem.")
(define-public python-flask
(package
(name "python-flask")
(version "0.10.1")
(version "0.11.1")
(source (origin
(method url-fetch)
(uri (pypi-uri "Flask" version))
(sha256
(base32
"0wrkavjdjndknhp8ya8j850jq7a1cli4g5a93mg8nh1xz2gq50sc"))))
"03kbfll4sj3v5z7r31c7bhfpi11r1np076d4p1k2kg4yzcmkywdl"))))
(build-system python-build-system)
(propagated-inputs
`(("python-itsdangerous" ,python-itsdangerous)
("python-jinja2" ,python-jinja2)
("python-werkzeug" ,python-werkzeug)))
(native-inputs
`(("python-click" ,python-click)))
(home-page "https://github.com/mitsuhiko/flask/")
(synopsis "Microframework based on Werkzeug, Jinja2 and good intentions")
(description "Flask is a micro web framework based on the Werkzeug toolkit
@ -9299,13 +9327,13 @@ ambiguities (forward vs. backward slashes, etc.).
(define-public python-jellyfish
(package
(name "python-jellyfish")
(version "0.5.3")
(version "0.5.6")
(source (origin
(method url-fetch)
(uri (pypi-uri "jellyfish" version))
(sha256
(base32
"12bxh8cy9xmvyrjz7aw159nd5pyvb645rkvw4r6bvm4xbvs8gd07"))))
"1j9rplb16ba2prjj6mip46z0w9pnhnqpwgiwi0x93vnas14rlyl8"))))
(build-system python-build-system)
(native-inputs
`(("python-pytest" ,python-pytest)))
@ -9352,15 +9380,13 @@ module, adding support for Unicode strings.")
(define-public python-rarfile
(package
(name "python-rarfile")
(version "2.7")
(version "2.8")
(source (origin
(method url-fetch)
(uri (pypi-uri "rarfile" version))
(sha256
(base32
"0d8n1dlpiz7av8dmbp0vclrwl9cnxizr4f2c9xvj1h5nvn480527"))
;; https://github.com/markokr/rarfile/pull/17/
(patches (search-patches "python-rarfile-fix-tests.patch"))))
"0qfad483kcbga0bn4qmcz953xjk16r52fahiy46zzn56v80y89ra"))))
(build-system python-build-system)
(arguments
'(#:phases

17
gnu/packages/ssh.scm
View File

@ -204,24 +204,24 @@ Additionally, various channel-specific options can be negotiated.")
(define-public guile-ssh
(package
(name "guile-ssh")
(version "0.10.1")
(version "0.10.2")
(home-page "https://github.com/artyom-poptsov/guile-ssh")
(source (origin
;; ftp://memory-heap.org/software/guile-ssh/guile-ssh-VERSION.tar.gz
;; exists, but the server appears to be too slow and unreliable.
(method git-fetch)
(uri (git-reference
(url "https://github.com/artyom-poptsov/libguile-ssh.git")
(commit (string-append "v" version))))
(file-name (string-append name "-" version "-checkout"))
;; Also, using this URL allows the GitHub updater to work.
(method url-fetch)
(uri (string-append home-page "/archive/v"
version ".tar.gz"))
(file-name (string-append name "-" version ".tar.gz"))
(sha256
(base32
"0ky77kr7rnkhbq938bir61mlr8b86lfjcjjb1bxx1y1fhimsiz72"))))
"0pkiq3fm15pr4w1r420rrwwfmi4jz492r6l6vzjk6v73xlyfyfl3"))))
(build-system gnu-build-system)
(arguments
'(#:phases (modify-phases %standard-phases
(add-after 'unpack 'autoreconf
(lambda* (#:key inputs #:allow-other-keys)
(chmod "doc/version.texi" #o777) ;make it writable
(zero? (system* "autoreconf" "-vfi"))))
(add-before 'build 'fix-libguile-ssh-file-name
(lambda* (#:key outputs #:allow-other-keys)
@ -255,7 +255,6 @@ Additionally, various channel-specific options can be negotiated.")
"Guile-SSH is a library that provides access to the SSH protocol for
programs written in GNU Guile interpreter. It is a wrapper to the underlying
libssh library.")
(home-page "https://github.com/artyom-poptsov/libguile-ssh")
(license license:gpl3+)))
(define-public corkscrew

340
gnu/packages/statistics.scm
View File

@ -3260,6 +3260,128 @@ noncentral hypergeometric distribution (also called extended hypergeometric
distribution).")
(license license:gpl3+)))
(define-public r-rematch
(package
(name "r-rematch")
(version "1.0.1")
(source
(origin
(method url-fetch)
(uri (cran-uri "rematch" version))
(sha256
(base32
"0y3mshvpvz9csmq8hk8jbabx4nxlv5sckvfzvm6920ndg34xw2d4"))))
(build-system r-build-system)
(home-page "https://github.com/MangoTheCat/rematch")
(synopsis "Match regular expressions with a nicer API")
(description
"This package provides a small wrapper on @code{regexpr} to extract the
matches and captured groups from the match of a regular expression to a
character vector.")
(license license:expat)))
(define-public r-cellranger
(package
(name "r-cellranger")
(version "1.1.0")
(source
(origin
(method url-fetch)
(uri (cran-uri "cellranger" version))
(sha256
(base32
"16fgi3annn34c3cxi0pxf62mmmmxi21hp0zzlv7bkfsjqy4g4f2x"))))
(build-system r-build-system)
(propagated-inputs
`(("r-rematch" ,r-rematch)
("r-tibble" ,r-tibble)))
(home-page "https://github.com/rsheets/cellranger")
(synopsis "Translate spreadsheet cell ranges to rows and columns")
(description
"This package provides helper functions to work with spreadsheets and the
@code{A1:D10} style of cell range specification.")
(license license:expat)))
(define-public r-googlesheets
(package
(name "r-googlesheets")
(version "0.2.1")
(source
(origin
(method url-fetch)
(uri (cran-uri "googlesheets" version))
(sha256
(base32
"0ps13h1cv7fj5dh8s4nvwi64wnnyqdsadcaa4iizq1c5s615cwk3"))))
(build-system r-build-system)
(propagated-inputs
`(("r-cellranger" ,r-cellranger)
("r-dplyr" ,r-dplyr)
("r-httr" ,r-httr)
("r-jsonlite" ,r-jsonlite)
("r-purrr" ,r-purrr)
("r-readr" ,r-readr)
("r-stringr" ,r-stringr)
("r-tidyr" ,r-tidyr)
("r-xml2" ,r-xml2)))
(home-page "https://github.com/jennybc/googlesheets")
(synopsis "Manage Google spreadsheets from R")
(description "This package provides tools to interact with Google Sheets
from within R.")
(license license:expat)))
(define-public r-spams
(package
(name "r-spams")
(version "2.5-svn2014-07-04")
(source
(origin
(method url-fetch)
(uri (string-append "https://gforge.inria.fr/frs/download.php/33815/"
"spams-R-v" version ".tar.gz"))
(sha256
(base32
"1k459jg9a334slkw31w63l4d39xszjzsng7dv5j1mp78zifz7hvx"))))
(build-system r-build-system)
(arguments
`(#:phases
(modify-phases %standard-phases
(add-after 'unpack 'chdir
(lambda _ (chdir "spams") #t))
;; Since R 3.3.0 including R headers inside of an extern "C" block
;; causes C headers to be included, which results in a lot of
;; duplicate definitions. This can be avoided by defining
;; NO_C_HEADERS before including the R headers.
(add-after 'chdir 'patch-use-of-R-headers
(lambda _
(substitute* "src/spams.cpp"
(("#include <R.h>" line)
(string-append "#define NO_C_HEADERS\n" line)))
#t))
;; This looks like a syntax error.
(add-after 'chdir 'patch-isnan
(lambda _
(substitute* '"src/spams/linalg/linalg.h"
(("if isnan\\(lambda\\) \\{")
"if (isnan(lambda)) {"))
#t)))))
(home-page "http://spams-devel.gforge.inria.fr")
(synopsis "Toolbox for solving sparse estimation problems")
(description "SPAMS (SPArse Modeling Software) is an optimization toolbox
for solving various sparse estimation problems. It includes tools for the
following problems:
@enumerate
@item Dictionary learning and matrix factorization (NMF, sparse @dfn{principle
component analysis} (PCA), ...)
@item Solving sparse decomposition problems with LARS, coordinate descent,
OMP, SOMP, proximal methods
@item Solving structured sparse decomposition problems (l1/l2, l1/linf, sparse
group lasso, tree-structured regularization, structured sparsity with
overlapping groups,...).
@end enumerate\n")
(license license:gpl3+)))
(define-public r-rpart
(package
(name "r-rpart")
@ -3363,6 +3485,224 @@ conversion of R objects to LaTeX code, and recoding variables.")
framework, with additional code inspection and report generation tools.")
(license license:gpl2+)))
(define-public r-dynamictreecut
(package
(name "r-dynamictreecut")
(version "1.63-1")
(source
(origin
(method url-fetch)
(uri (cran-uri "dynamicTreeCut" version))
(sha256
(base32
"1fadbql7g5r2vvlkr89nlrjxwp4yx4xrdqmv077qvmnx9vv0f4w3"))))
(properties `((upstream-name . "dynamicTreeCut")))
(build-system r-build-system)
(home-page
"http://www.genetics.ucla.edu/labs/horvath/CoexpressionNetwork/BranchCutting/")
(synopsis "Detect clusters in hierarchical clustering dendrograms")
(description
"This package contains methods for the detection of clusters in
hierarchical clustering dendrograms.")
(license license:gpl2+)))
(define-public r-preprocesscore
(package
(name "r-preprocesscore")
(version "1.36.0")
(source
(origin
(method url-fetch)
(uri (bioconductor-uri "preprocessCore" version))
(sha256
(base32
"1n8y12q7145f385gm2k3c6y3vwvin7jlb47la4mnl7mar6pq9kmp"))))
(properties
`((upstream-name . "preprocessCore")))
(build-system r-build-system)
(home-page "https://github.com/bmbolstad/preprocessCore")
(synopsis "Collection of pre-processing functions")
(description
"This package provides a library of core pre-processing and normalization
routines.")
(license license:lgpl2.0+)))
(define-public r-fastcluster
(package
(name "r-fastcluster")
(version "1.1.20")
(source
(origin
(method url-fetch)
(uri (cran-uri "fastcluster" version))
(sha256
(base32
"0rlbxhh894znf10x0xgkv9dzpibgq9jw5aqpgviccdnxc2c5hwid"))))
(build-system r-build-system)
(home-page "http://danifold.net/fastcluster.html")
(synopsis "Fast hierarchical clustering routines")
(description
"This package implements fast hierarchical, agglomerative clustering
routines. Part of the functionality is designed as drop-in replacement for
existing routines: @code{linkage()} in the SciPy package
@code{scipy.cluster.hierarchy}, @code{hclust()} in R's @code{stats} package,
and the @code{flashClust} package. It provides the same functionality with
the benefit of a much faster implementation. Moreover, there are
memory-saving routines for clustering of vector data, which go beyond what the
existing packages provide.")
(license license:bsd-2)))
(define-public r-sfsmisc
(package
(name "r-sfsmisc")
(version "1.1-0")
(source
(origin
(method url-fetch)
(uri (cran-uri "sfsmisc" version))
(sha256
(base32
"0580piv4n1nispl3pa8nfjjfnb8iwaqky2dzdy0aqnxrxgrhqhvz"))))
(build-system r-build-system)
(home-page "http://cran.r-project.org/web/packages/sfsmisc")
(synopsis "Utilities from \"Seminar fuer Statistik\" ETH Zurich")
(description
"This package provides useful utilities from Seminar fuer Statistik ETH
Zurich, including many that are related to graphics.")
(license license:gpl2+)))
(define-public r-gtools
(package
(name "r-gtools")
(version "3.5.0")
(source
(origin
(method url-fetch)
(uri (cran-uri "gtools" version))
(sha256
(base32
"1xknwk9xlsj027pg0nwiizigcrsc84hdrig0jn0cgcyxj8dabdl6"))))
(build-system r-build-system)
(home-page "http://cran.r-project.org/web/packages/gtools")
(synopsis "Various R programming tools")
(description
"This package contains a collection of various functions to assist in R
programming, such as tools to assist in developing, updating, and maintaining
R and R packages, calculating the logit and inverse logit transformations,
tests for whether a value is missing, empty or contains only @code{NA} and
@code{NULL} values, and many more.")
(license license:gpl2)))
(define-public r-gdata
(package
(name "r-gdata")
(version "2.17.0")
(source
(origin
(method url-fetch)
(uri (cran-uri "gdata" version))
(sha256
(base32
"0kiy3jbcszlpmarg311spdsfi5pn89wgy742dxsbzxk8907fr5w0"))))
(build-system r-build-system)
(inputs
`(("perl" ,perl)))
(propagated-inputs
`(("r-gtools" ,r-gtools)))
(home-page "http://cran.r-project.org/web/packages/gdata")
(synopsis "Various R programming tools for data manipulation")
(description
"This package provides various R programming tools for data manipulation,
including:
@itemize
@item medical unit conversions
@item combining objects
@item character vector operations
@item factor manipulation
@item obtaining information about R objects
@item manipulating MS-Excel formatted files
@item generating fixed-width format files
@item extricating components of date and time objects
@item operations on columns of data frames
@item matrix operations
@item operations on vectors and data frames
@item value of last evaluated expression
@item wrapper for @code{sample} that ensures consistent behavior for
both scalar and vector arguments
@end itemize\n")
(license license:gpl2+)))
(define-public r-gplots
(package
(name "r-gplots")
(version "3.0.1")
(source
(origin
(method url-fetch)
(uri (cran-uri "gplots" version))
(sha256
(base32
"02nb8n3s7c1zxq2s7ycaq2ys72y7mzirxrwj954h6gdc4x1zhg9l"))))
(build-system r-build-system)
(propagated-inputs
`(("r-catools" ,r-catools)
("r-gdata" ,r-gdata)
("r-gtools" ,r-gtools)
("r-kernsmooth" ,r-kernsmooth)))
(home-page "http://cran.r-project.org/web/packages/gplots")
(synopsis "Various R programming tools for plotting data")
(description
"This package provides various R programming tools for plotting data,
including:
@itemize
@item calculating and plotting locally smoothed summary function
@item enhanced versions of standard plots
@item manipulating colors
@item calculating and plotting two-dimensional data summaries
@item enhanced regression diagnostic plots
@item formula-enabled interface to @code{stats::lowess} function
@item displaying textual data in plots
@item baloon plots
@item plotting \"Venn\" diagrams
@item displaying Open-Office style plots
@item plotting multiple data on same region, with separate axes
@item plotting means and confidence intervals
@item spacing points in an x-y plot so they don't overlap
@end itemize\n")
(license license:gpl2+)))
(define-public r-rocr
(package
(name "r-rocr")
(version "1.0-7")
(source
(origin
(method url-fetch)
(uri (cran-uri "ROCR" version))
(sha256
(base32
"1jay8cm7lgq56i967vm5c2hgaxqkphfpip0gn941li3yhh7p3vz7"))))
(properties `((upstream-name . "ROCR")))
(build-system r-build-system)
(propagated-inputs
`(("r-gplots" ,r-gplots)))
(home-page "http://rocr.bioinf.mpi-sb.mpg.de/")
(synopsis "Visualizing the performance of scoring classifiers")
(description
"ROCR is a flexible tool for creating cutoff-parameterized 2D performance
curves by freely combining two from over 25 performance measures (new
performance measures can be added using a standard interface). Curves from
different cross-validation or bootstrapping runs can be averaged by different
methods, and standard deviations, standard errors or box plots can be used to
visualize the variability across the runs. The parameterization can be
visualized by printing cutoff values at the corresponding curve positions, or
by coloring the curve according to cutoff. All components of a performance
plot can be quickly adjusted using a flexible parameter dispatching
mechanism.")
(license license:gpl2+)))
(define-public r-kernsmooth
(package
(name "r-kernsmooth")

112
gnu/packages/telephony.scm
View File

@ -5,6 +5,7 @@
;;; Copyright © 2015 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2016 Lukas Gradl <lgradl@openmailbox.org>
;;; Copyright © 2016 Francesco Frassinelli <fraph24@gmail.com>
;;; Copyright © 2016 ng0 <ng0@libertad.pw>
;;;
;;; This file is part of GNU Guix.
;;;
@ -24,13 +25,20 @@
(define-module (gnu packages telephony)
#:use-module (gnu packages)
#:use-module (gnu packages autotools)
#:use-module (gnu packages avahi)
#:use-module (gnu packages boost)
#:use-module (gnu packages protobuf)
#:use-module (gnu packages gnupg)
#:use-module (gnu packages linux)
#:use-module (gnu packages multiprecision)
#:use-module (gnu packages ncurses)
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages pulseaudio)
#:use-module (gnu packages qt)
#:use-module (gnu packages speech)
#:use-module (gnu packages tls)
#:use-module (gnu packages xiph)
#:use-module (gnu packages xorg)
#:use-module ((guix licenses) #:prefix license:)
#:use-module (guix packages)
#:use-module (guix download)
@ -287,3 +295,107 @@ lists. All you need to join an existing conference is the host name or IP
address of one of the participants.")
(home-page "http://holdenc.altervista.org/seren/")
(license license:gpl3+)))
(define-public mumble
(package
(name "mumble")
(version "1.2.17")
(source (origin
(method url-fetch)
(uri (string-append "https://mumble.info/snapshot/"
name "-" version ".tar.gz"))
(sha256
(base32
"176br3b0pv5sz3zvgzsz9rxr3n79irlm902h7n1wh4f6vbph2dhw"))
(modules '((guix build utils)))
(snippet
`(begin
;; Remove bundled software.
(for-each delete-file-recursively '("3rdparty"
"speex"
"speexbuild"
"opus-build"
"opus-src"
"sbcelt-helper-build"
"sbcelt-lib-build"
"sbcelt-src"))
;; TODO: Celt is still bundled. It has been merged into Opus
;; and will be removed after 1.3.0.
;; https://github.com/mumble-voip/mumble/issues/1999
#t))))
(build-system gnu-build-system)
(arguments
`(#:tests? #f ; no "check" target
#:phases
(modify-phases %standard-phases
(replace 'configure
(lambda* (#:key outputs #:allow-other-keys)
(zero? (system* "qmake" "main.pro" "-recursive"
(string-append "CONFIG+="
(string-join
(list "no-update"
"no-server"
"no-embed-qt-translations"
"no-bundled-speex"
"pch"
"no-bundled-opus"
"no-celt"
"no-alsa"
"no-oss"
"no-portaudio"
"speechd"
"no-g15"
"no-bonjour"
"release")))
(string-append "DEFINES+="
"PLUGIN_PATH="
(assoc-ref outputs "out")
"/lib/mumble")))))
(add-before 'configure 'fix-libspeechd-include
(lambda _
(substitute* "src/mumble/TextToSpeech_unix.cpp"
(("libspeechd.h") "speech-dispatcher/libspeechd.h"))))
(replace 'install ; install phase does not exist
(lambda* (#:key inputs outputs #:allow-other-keys)
(let* ((out (assoc-ref outputs "out"))
(bin (string-append out "/bin"))
(services (string-append out "/share/services"))
(applications (string-append out "/share/applications"))
(icons (string-append out "/share/icons/hicolor/scalable/apps"))
(man (string-append out "/share/man/man1"))
(lib (string-append out "/lib/mumble")))
(install-file "release/mumble" bin)
(install-file "scripts/mumble-overlay" bin)
(install-file "scripts/mumble.protocol" services)
(install-file "scripts/mumble.desktop" applications)
(install-file "icons/mumble.svg" icons)
(install-file "man/mumble-overlay.1" man)
(install-file "man/mumble.1" man)
(for-each (lambda (file) (install-file file lib))
(find-files "." "\\.so\\."))
(for-each (lambda (file) (install-file file lib))
(find-files "release/plugins" "\\.so$"))))))))
(inputs
`(("avahi" ,avahi)
("protobuf" ,protobuf)
("openssl" ,openssl)
("libsndfile" ,libsndfile)
("boost" ,boost)
("opus" ,opus)
("speex" ,speex)
("speech-dispatcher" ,speech-dispatcher)
("libx11" ,libx11)
("libxi" ,libxi)
("qt-4" ,qt-4)
("alsa-lib" ,alsa-lib)
("pulseaudio" ,pulseaudio)))
(native-inputs
`(("pkg-config" ,pkg-config)))
(synopsis "Low-latency, high quality voice chat software")
(description
"Mumble is an low-latency, high quality voice chat
software primarily intended for use while gaming.")
(home-page "https://wiki.mumble.info/wiki/Main_Page")
(license (list license:bsd-3
;; The bundled celt is bsd-2. Remove after 1.3.0.
license:bsd-2))))

152
gnu/packages/tex.scm
View File

@ -6,6 +6,7 @@
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2016 Federico Beffa <beffa@fbengineering.ch>
;;; Copyright © 2016 Thomas Danckaert <post@thomasdanckaert.be>
;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of GNU Guix.
;;;
@ -27,6 +28,7 @@
#:use-module (guix packages)
#:use-module (guix download)
#:use-module (guix build-system gnu)
#:use-module (guix build-system perl)
#:use-module (guix build-system trivial)
#:use-module (guix utils)
#:use-module (guix git-download)
@ -50,6 +52,8 @@
#:use-module (gnu packages ruby)
#:use-module (gnu packages shells)
#:use-module (gnu packages base)
#:use-module (gnu packages web)
#:use-module (gnu packages xml)
#:use-module (gnu packages xorg)
#:use-module (gnu packages xdisorg)
#:use-module (gnu packages zip)
@ -382,6 +386,154 @@ world.
This package contains a small working part of the TeX Live distribution.")))
(define-public perl-text-bibtex
(package
(name "perl-text-bibtex")
(version "0.77")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://cpan/authors/id/A/AM/AMBS/Text-BibTeX-"
version ".tar.gz"))
(sha256
(base32
"0kkfx8skk763pivz6h2ffy2zdp1lvy6d5sz0kjaj0mdbjffvnnb4"))))
(build-system perl-build-system)
(arguments
`(#:phases
(modify-phases %standard-phases
(add-after 'unpack 'add-output-directory-to-rpath
(lambda* (#:key outputs #:allow-other-keys)
(substitute* "inc/MyBuilder.pm"
(("-Lbtparse" line)
(string-append "-Wl,-rpath="
(assoc-ref outputs "out") "/lib " line)))
#t))
(add-after 'unpack 'install-libraries-to-/lib
(lambda* (#:key outputs #:allow-other-keys)
(substitute* "Build.PL"
(("lib64") "lib"))
#t)))))
(native-inputs
`(("perl-capture-tiny" ,perl-capture-tiny)
("perl-config-autoconf" ,perl-config-autoconf)
("perl-extutils-libbuilder" ,perl-extutils-libbuilder)
("perl-module-build" ,perl-module-build)))
(home-page "http://search.cpan.org/dist/Text-BibTeX")
(synopsis "Interface to read and parse BibTeX files")
(description "@code{Text::BibTeX} is a Perl library for reading, parsing,
and processing BibTeX files. @code{Text::BibTeX} gives you access to the data
at many different levels: you may work with BibTeX entries as simple field to
string mappings, or get at the original form of the data as a list of simple
values (strings, macros, or numbers) pasted together.")
(license (package-license perl))))
(define-public biber
(package
(name "biber-next")
(version "2.6")
(source (origin
(method url-fetch)
(uri (string-append "https://github.com/plk/biber/archive/v"
version ".tar.gz"))
(file-name (string-append name "-" version ".tar.gz"))
(sha256
(base32
"158smzgjhjvyabdv97si5q88zjj5l8j1zbfnddvzy6fkpfhskgkp"))))
(build-system perl-build-system)
(arguments
`(#:phases
(modify-phases %standard-phases
(add-after 'install 'wrap-programs
(lambda* (#:key outputs #:allow-other-keys)
(let* ((out (assoc-ref outputs "out"))
(perl5lib (getenv "PERL5LIB")))
(wrap-program (string-append out "/bin/biber")
`("PERL5LIB" ":" prefix
(,(string-append perl5lib ":" out
"/lib/perl5/site_perl")))))
#t)))))
(inputs
`(("perl-autovivification" ,perl-autovivification)
("perl-class-accessor" ,perl-class-accessor)
("perl-data-dump" ,perl-data-dump)
("perl-data-compare" ,perl-data-compare)
("perl-data-uniqid" ,perl-data-uniqid)
("perl-datetime-format-builder" ,perl-datetime-format-builder)
("perl-datetime-calendar-julian" ,perl-datetime-calendar-julian)
("perl-file-slurp" ,perl-file-slurp)
("perl-ipc-cmd" ,perl-ipc-cmd)
("perl-ipc-run3" ,perl-ipc-run3)
("perl-list-allutils" ,perl-list-allutils)
("perl-list-moreutils" ,perl-list-moreutils)
("perl-mozilla-ca" ,perl-mozilla-ca)
("perl-regexp-common" ,perl-regexp-common)
("perl-log-log4perl" ,perl-log-log4perl)
;; We cannot use perl-unicode-collate here, because otherwise the
;; hardcoded hashes in the tests would differ. See
;; https://mail-archive.com/debian-bugs-dist@lists.debian.org/msg1469249.html
;;("perl-unicode-collate" ,perl-unicode-collate)
("perl-unicode-normalize" ,perl-unicode-normalize)
("perl-unicode-linebreak" ,perl-unicode-linebreak)
("perl-encode-eucjpascii" ,perl-encode-eucjpascii)
("perl-encode-jis2k" ,perl-encode-jis2k)
("perl-encode-hanextra" ,perl-encode-hanextra)
("perl-xml-libxml" ,perl-xml-libxml)
("perl-xml-libxml-simple" ,perl-xml-libxml-simple)
("perl-xml-libxslt" ,perl-xml-libxslt)
("perl-xml-writer" ,perl-xml-writer)
("perl-sort-key" ,perl-sort-key)
("perl-text-csv" ,perl-text-csv)
("perl-text-csv-xs" ,perl-text-csv-xs)
("perl-text-roman" ,perl-text-roman)
("perl-uri" ,perl-uri)
("perl-text-bibtex" ,perl-text-bibtex)
("perl-libwww" ,perl-libwww)
("perl-lwp-protocol-https" ,perl-lwp-protocol-https)
("perl-business-isbn" ,perl-business-isbn)
("perl-business-issn" ,perl-business-issn)
("perl-business-ismn" ,perl-business-ismn)
("perl-lingua-translit" ,perl-lingua-translit)))
(native-inputs
`(("perl-config-autoconf" ,perl-config-autoconf)
("perl-extutils-libbuilder" ,perl-extutils-libbuilder)
("perl-module-build" ,perl-module-build)
;; for tests
("perl-file-which" ,perl-file-which)
("perl-test-more" ,perl-test-most) ; FIXME: "more" would be sufficient
("perl-test-differences" ,perl-test-differences)))
(home-page "http://biblatex-biber.sourceforge.net/")
(synopsis "Backend for the BibLaTeX citation management tool")
(description "Biber is a BibTeX replacement for users of biblatex. Among
other things it comes with full Unicode support.")
(license license:artistic2.0)))
;; Our version of texlive comes with biblatex 3.4, which is only compatible
;; with biber 2.5 according to the compatibility matrix in the biber
;; documentation.
(define-public biber-2.5
(package (inherit biber)
(name "biber")
(version "2.5")
(source (origin
(method url-fetch)
(uri (string-append "https://github.com/plk/biber/archive/v"
version ".tar.gz"))
(file-name (string-append name "-" version ".tar.gz"))
(sha256
(base32
"163sd343wkrzwnvj2003m2j0kz517jmjr4savw6f8bjxhj8fdrqv"))))
(arguments
(substitute-keyword-arguments (package-arguments biber)
((#:phases phases)
`(modify-phases ,phases
(add-before 'check 'delete-failing-test
(lambda _
(delete-file "t/sort-order.t")
#t))))))
(inputs
`(("perl-date-simple" ,perl-date-simple)
,@(package-inputs biber)))))
(define-public rubber
(package

4
gnu/packages/video.scm
View File

@ -441,14 +441,14 @@ standards (MPEG-2, MPEG-4 ASP/H.263, MPEG-4 AVC/H.264, and VC-1/VMW3).")
(define-public ffmpeg
(package
(name "ffmpeg")
(version "3.2")
(version "3.2.1")
(source (origin
(method url-fetch)
(uri (string-append "https://ffmpeg.org/releases/ffmpeg-"
version ".tar.xz"))
(sha256
(base32
"1nnmd3h9pr2zic08isjcm1cmvcyd0aimpayb9r4qy45bihdhrxw8"))))
"1pxsy9s9n2nvz970rid3j3b45w6s7ziwnrbc16rny7k0bpd97kqy"))))
(build-system gnu-build-system)
(inputs
`(("fontconfig" ,fontconfig)

34
gnu/packages/wget.scm
View File

@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;;
;;; This file is part of GNU Guix.
;;;
@ -60,3 +61,36 @@ HTTPS and FTP protocols. It can resume interrupted downloads, use file name
wild cards, supports proxies and cookies, and it can convert absolute links
in downloaded documents to relative links.")
(license gpl3+))) ; some files are under GPLv2+
(define-public wgetpaste
(package
(name "wgetpaste")
(version "2.28")
(source
(origin
(method url-fetch)
(uri (string-append "http://wgetpaste.zlin.dk/wgetpaste-"
version ".tar.bz2"))
(sha256
(base32
"1hh9svyypqcvdg5mjxyyfzpdzhylhf7s7xq5dzglnm4injx3i3ak"))))
(build-system gnu-build-system)
(arguments
'(#:phases
(modify-phases %standard-phases
(delete 'configure)
(delete 'build)
(replace 'install
(lambda* (#:key outputs #:allow-other-keys)
(let* ((out (assoc-ref outputs "out"))
(bin (string-append out "/bin"))
(zsh (string-append out "/share/zsh/site-functions")))
(install-file "wgetpaste" bin)
(install-file "_wgetpaste" zsh)))))
#:tests? #f)) ; no test target
(home-page "http://wgetpaste.zlin.dk/")
(synopsis "Script that automates pasting to a number of pastebin services")
(description
"@code{wgetpaste} is an extremely simple command-line interface to various
online pastebin services.")
(license public-domain)))

31
gnu/packages/wine.scm
View File

@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015 Sou Bunnbu <iyzsong@gmail.com>
;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;;
;;; This file is part of GNU Guix.
;;;
@ -52,7 +53,7 @@
(define-public wine
(package
(name "wine")
(version "1.9.15")
(version "1.9.24")
(source (origin
(method url-fetch)
(uri (string-append "https://dl.winehq.org/wine/source/"
@ -60,7 +61,7 @@
"/wine-" version ".tar.bz2"))
(sha256
(base32
"1nmd65knzyh8b0yhxlqqvzai5rpnmhhm0c46n789zr5hj74jm6fg"))))
"0qb07vfxwz41wj71lb0ss3apf22m4ch06382rqfksf7gg34pswnb"))))
(build-system gnu-build-system)
(native-inputs `(("pkg-config" ,pkg-config)
("gettext" ,gettext-minimal)
@ -117,19 +118,19 @@
(list "SHELL=bash")
#:phases
(alist-cons-after
'configure 'patch-dlopen-paths
;; Hardcode dlopened sonames to absolute paths.
(lambda _
(let* ((library-path (search-path-as-string->list
(getenv "LIBRARY_PATH")))
(find-so (lambda (soname)
(search-path library-path soname))))
(substitute* "include/config.h"
(("(#define SONAME_.* )\"(.*)\"" _ defso soname)
(format #f "~a\"~a\"" defso (find-so soname))))))
%standard-phases)))
(home-page "http://www.winehq.org/")
(modify-phases %standard-phases
(add-after 'configure 'patch-dlopen-paths
;; Hardcode dlopened sonames to absolute paths.
(lambda _
(let* ((library-path (search-path-as-string->list
(getenv "LIBRARY_PATH")))
(find-so (lambda (soname)
(search-path library-path soname))))
(substitute* "include/config.h"
(("(#define SONAME_.* )\"(.*)\"" _ defso soname)
(format #f "~a\"~a\"" defso (find-so soname))))
#t))))))
(home-page "https://www.winehq.org/")
(synopsis "Implementation of the Windows API")
(description
"Wine (originally an acronym for \"Wine Is Not an Emulator\") is a

23
gnu/packages/xml.scm
View File

@ -329,6 +329,29 @@ XML parser and the high performance DOM implementation.")
@code{XML::LibXML}.")
(license (package-license perl))))
(define-public perl-xml-libxslt
(package
(name "perl-xml-libxslt")
(version "1.95")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://cpan/authors/id/S/SH/SHLOMIF/"
"XML-LibXSLT-" version ".tar.gz"))
(sha256
(base32
"0dggycql18kfxzkb1kw3yc7gslxlrrgyyn2r2ygsylycb89j3jpi"))))
(build-system perl-build-system)
(inputs
`(("libxslt" ,libxslt)))
(propagated-inputs
`(("perl-xml-libxml" ,perl-xml-libxml)))
(home-page "http://search.cpan.org/dist/XML-LibXSLT")
(synopsis "Perl bindings to GNOME libxslt library")
(description "This Perl module is an interface to the GNOME project's
libxslt library.")
(license (package-license perl))))
(define-public perl-xml-namespacesupport
(package
(name "perl-xml-namespacesupport")

39
gnu/packages/xorg.scm
View File

@ -10,6 +10,7 @@
;;; Copyright © 2016 ng0 <ng0@we.make.ritual.n0.is>
;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
;;; Copyright © 2016 David Craven <david@craven.ch>
;;; Copyright © 2016 John Darrington <jmd@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@ -335,6 +336,44 @@ provided.")
"See 'dri3proto.h' in the distribution."))))
(define-public editres
(package
(name "editres")
(version "1.0.6")
(source
(origin
(method url-fetch)
(uri (string-append
"mirror://xorg/individual/app/" name "-"
version
".tar.bz2"))
(sha256
(base32
"1w2d5hb5pw9ii2jlf4yjlp899402zfwc8hdkpdr3i1fy1cjd2riv"))))
(build-system gnu-build-system)
(arguments
`(#:configure-flags
(list (string-append "--with-appdefaultdir="
%output "/lib/X11/app-defaults"))))
(inputs
`(("libxaw" ,libxaw)
("libxmu" ,libxmu)
("libxt" ,libxt)))
(native-inputs
`(("pkg-config" ,pkg-config)))
(home-page "https://www.x.org/wiki/")
(synopsis "Tool to browse and edit X Toolkit resource specifications")
(description
"Editres is a tool that allows users and application developers to view
the full widget hierarchy of any X Toolkit application that speaks the Editres
protocol. In addition, editres will help the user construct resource
specifications, allow the user to apply the resource to the application and
view the results dynamically. Once the user is happy with a resource
specification editres will append the resource string to the user's X
Resources file.")
(license license:x11)))
(define-public encodings
(package
(name "encodings")

205
gnu/services/configuration.scm Normal file
View File

@ -0,0 +1,205 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Andy Wingo <wingo@igalia.com>
;;;
;;; 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 services configuration)
#:use-module (guix packages)
#:use-module (guix records)
#:use-module (guix gexp)
#:autoload (texinfo) (texi-fragment->stexi)
#:autoload (texinfo serialize) (stexi->texi)
#:use-module (ice-9 match)
#:use-module ((srfi srfi-1) #:select (append-map))
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:export (configuration-field
configuration-field-name
configuration-missing-field
configuration-field-error
serialize-configuration
define-configuration
validate-configuration
generate-documentation
serialize-field
serialize-string
serialize-name
serialize-space-separated-string-list
space-separated-string-list?
serialize-file-name
file-name?
serialize-boolean
serialize-package))
;;; Commentary:
;;;
;;; Syntax for creating Scheme bindings to complex configuration files.
;;;
;;; Code:
(define-condition-type &configuration-error &error
configuration-error?)
(define (configuration-error message)
(raise (condition (&message (message message))
(&configuration-error))))
(define (configuration-field-error field val)
(configuration-error
(format #f "Invalid value for field ~a: ~s" field val)))
(define (configuration-missing-field kind field)
(configuration-error
(format #f "~a configuration missing required field ~a" kind field)))
(define-record-type* <configuration-field>
configuration-field make-configuration-field configuration-field?
(name configuration-field-name)
(type configuration-field-type)
(getter configuration-field-getter)
(predicate configuration-field-predicate)
(serializer configuration-field-serializer)
(default-value-thunk configuration-field-default-value-thunk)
(documentation configuration-field-documentation))
(define (serialize-configuration config fields)
(for-each (lambda (field)
((configuration-field-serializer field)
(configuration-field-name field)
((configuration-field-getter field) config)))
fields))
(define (validate-configuration config fields)
(for-each (lambda (field)
(let ((val ((configuration-field-getter field) config)))
(unless ((configuration-field-predicate field) val)
(configuration-field-error
(configuration-field-name field) val))))
fields))
(define-syntax define-configuration
(lambda (stx)
(define (id ctx part . parts)
(let ((part (syntax->datum part)))
(datum->syntax
ctx
(match parts
(() part)
(parts (symbol-append part
(syntax->datum (apply id ctx parts))))))))
(syntax-case stx ()
((_ stem (field (field-type def) doc) ...)
(with-syntax (((field-getter ...)
(map (lambda (field)
(id #'stem #'stem #'- field))
#'(field ...)))
((field-predicate ...)
(map (lambda (type)
(id #'stem type #'?))
#'(field-type ...)))
((field-serializer ...)
(map (lambda (type)
(id #'stem #'serialize- type))
#'(field-type ...))))
#`(begin
(define-record-type* #,(id #'stem #'< #'stem #'>)
#,(id #'stem #'% #'stem)
#,(id #'stem #'make- #'stem)
#,(id #'stem #'stem #'?)
(field field-getter (default def))
...)
(define #,(id #'stem #'stem #'-fields)
(list (configuration-field
(name 'field)
(type 'field-type)
(getter field-getter)
(predicate field-predicate)
(serializer field-serializer)
(default-value-thunk (lambda () def))
(documentation doc))
...))
(define-syntax-rule (stem arg (... ...))
(let ((conf (#,(id #'stem #'% #'stem) arg (... ...))))
(validate-configuration conf
#,(id #'stem #'stem #'-fields))
conf))))))))
(define (uglify-field-name field-name)
(let ((str (symbol->string field-name)))
(string-concatenate
(map string-titlecase
(string-split (if (string-suffix? "?" str)
(substring str 0 (1- (string-length str)))
str)
#\-)))))
(define (serialize-field field-name val)
(format #t "~a ~a\n" (uglify-field-name field-name) val))
(define (serialize-package field-name val)
#f)
(define (serialize-string field-name val)
(serialize-field field-name val))
(define (space-separated-string-list? val)
(and (list? val)
(and-map (lambda (x)
(and (string? x) (not (string-index x #\space))))
val)))
(define (serialize-space-separated-string-list field-name val)
(serialize-field field-name (string-join val " ")))
(define (file-name? val)
(and (string? val)
(string-prefix? "/" val)))
(define (serialize-file-name field-name val)
(serialize-string field-name val))
(define (serialize-boolean field-name val)
(serialize-string field-name (if val "yes" "no")))
;; A little helper to make it easier to document all those fields.
(define (generate-documentation documentation documentation-name)
(define (str x) (object->string x))
(define (generate configuration-name)
(match (assq-ref documentation configuration-name)
((fields . sub-documentation)
`((para "Available " (code ,(str configuration-name)) " fields are:")
,@(map
(lambda (f)
(let ((field-name (configuration-field-name f))
(field-type (configuration-field-type f))
(field-docs (cdr (texi-fragment->stexi
(configuration-field-documentation f))))
(default (catch #t
(configuration-field-default-value-thunk f)
(lambda _ '%invalid))))
(define (show-default? val)
(or (string? default) (number? default) (boolean? default)
(and (symbol? val) (not (eq? val '%invalid)))
(and (list? val) (and-map show-default? val))))
`(deftypevr (% (category
(code ,(str configuration-name)) " parameter")
(data-type ,(str field-type))
(name ,(str field-name)))
,@field-docs
,@(if (show-default? default)
`((para "Defaults to " (samp ,(str default)) "."))
'())
,@(append-map
generate
(or (assq-ref sub-documentation field-name) '())))))
fields)))))
(stexi->texi `(*fragment* . ,(generate documentation-name))))

180
gnu/services/cups.scm
View File

@ -19,6 +19,7 @@
(define-module (gnu services cups)
#:use-module (gnu services)
#:use-module (gnu services shepherd)
#:use-module (gnu services configuration)
#:use-module (gnu system shadow)
#:use-module (gnu packages admin)
#:use-module (gnu packages cups)
@ -26,16 +27,9 @@
#:use-module (guix packages)
#:use-module (guix records)
#:use-module (guix gexp)
#:use-module (texinfo)
#:use-module (texinfo serialize)
#:use-module (ice-9 match)
#:use-module ((srfi srfi-1) #:select (append-map))
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:export (&cups-configuation-error
cups-configuration-error?
cups-service-type
#:export (cups-service-type
cups-configuration
opaque-cups-configuration
@ -51,91 +45,6 @@
;;;
;;; Code:
(define-condition-type &cups-configuration-error &error
cups-configuration-error?)
(define (cups-error message)
(raise (condition (&message (message message))
(&cups-configuration-error))))
(define (cups-configuration-field-error field val)
(cups-error
(format #f "Invalid value for field ~a: ~s" field val)))
(define (cups-configuration-missing-field kind field)
(cups-error
(format #f "~a configuration missing required field ~a" kind field)))
(define-record-type* <configuration-field>
configuration-field make-configuration-field configuration-field?
(name configuration-field-name)
(type configuration-field-type)
(getter configuration-field-getter)
(predicate configuration-field-predicate)
(serializer configuration-field-serializer)
(default-value-thunk configuration-field-default-value-thunk)
(documentation configuration-field-documentation))
(define (serialize-configuration config fields)
(for-each (lambda (field)
((configuration-field-serializer field)
(configuration-field-name field)
((configuration-field-getter field) config)))
fields))
(define (validate-configuration config fields)
(for-each (lambda (field)
(let ((val ((configuration-field-getter field) config)))
(unless ((configuration-field-predicate field) val)
(cups-configuration-field-error
(configuration-field-name field) val))))
fields))
(define-syntax define-configuration
(lambda (stx)
(define (id ctx part . parts)
(let ((part (syntax->datum part)))
(datum->syntax
ctx
(match parts
(() part)
(parts (symbol-append part
(syntax->datum (apply id ctx parts))))))))
(syntax-case stx ()
((_ stem (field (field-type def) doc) ...)
(with-syntax (((field-getter ...)
(map (lambda (field)
(id #'stem #'stem #'- field))
#'(field ...)))
((field-predicate ...)
(map (lambda (type)
(id #'stem type #'?))
#'(field-type ...)))
((field-serializer ...)
(map (lambda (type)
(id #'stem #'serialize- type))
#'(field-type ...))))
#`(begin
(define-record-type* #,(id #'stem #'< #'stem #'>)
#,(id #'stem #'% #'stem)
#,(id #'stem #'make- #'stem)
#,(id #'stem #'stem #'?)
(field field-getter (default def))
...)
(define #,(id #'stem #'stem #'-fields)
(list (configuration-field
(name 'field)
(type 'field-type)
(getter field-getter)
(predicate field-predicate)
(serializer field-serializer)
(default-value-thunk (lambda () def))
(documentation doc))
...))
(define-syntax-rule (stem arg (... ...))
(let ((conf (#,(id #'stem #'% #'stem) arg (... ...))))
(validate-configuration conf
#,(id #'stem #'stem #'-fields))
conf))))))))
(define %cups-accounts
(list (user-group (name "lp") (system? #t))
(user-group (name "lpadmin") (system? #t))
@ -147,24 +56,6 @@
(home-directory "/var/empty")
(shell (file-append shadow "/sbin/nologin")))))
(define (uglify-field-name field-name)
(let ((str (symbol->string field-name)))
(string-concatenate
(map string-titlecase
(string-split (if (string-suffix? "?" str)
(substring str 0 (1- (string-length str)))
str)
#\-)))))
(define (serialize-field field-name val)
(format #t "~a ~a\n" (uglify-field-name field-name) val))
(define (serialize-package field-name val)
#f)
(define (serialize-string field-name val)
(serialize-field field-name val))
(define (multiline-string-list? val)
(and (list? val)
(and-map (lambda (x)
@ -173,28 +64,11 @@
(define (serialize-multiline-string-list field-name val)
(for-each (lambda (str) (serialize-field field-name str)) val))
(define (space-separated-string-list? val)
(and (list? val)
(and-map (lambda (x)
(and (string? x) (not (string-index x #\space))))
val)))
(define (serialize-space-separated-string-list field-name val)
(serialize-field field-name (string-join val " ")))
(define (space-separated-symbol-list? val)
(and (list? val) (and-map symbol? val)))
(define (serialize-space-separated-symbol-list field-name val)
(serialize-field field-name (string-join (map symbol->string val) " ")))
(define (file-name? val)
(and (string? val)
(string-prefix? "/" val)))
(define (serialize-file-name field-name val)
(serialize-string field-name val))
(define (serialize-boolean field-name val)
(serialize-string field-name (if val "yes" "no")))
(define (non-negative-integer? val)
(and (exact-integer? val) (not (negative? val))))
(define (serialize-non-negative-integer field-name val)
@ -333,7 +207,7 @@ methods. Otherwise apply to only the listed methods.")
(define-configuration location-access-control
(path
(file-name (cups-configuration-missing-field 'location-access-control 'path))
(file-name (configuration-missing-field 'location-access-control 'path))
"Specifies the URI path to which the access control applies.")
(access-controls
(access-control-list '())
@ -359,7 +233,7 @@ methods. Otherwise apply to only the listed methods.")
(define-configuration policy-configuration
(name
(string (cups-configuration-missing-field 'policy-configuration 'name))
(string (configuration-missing-field 'policy-configuration 'name))
"Name of the policy.")
(job-private-access
(string "@OWNER @SYSTEM")
@ -925,12 +799,12 @@ IPP specifications.")
(package-list '())
"Drivers and other extensions to the CUPS package.")
(cupsd.conf
(string (cups-configuration-missing-field 'opaque-cups-configuration
'cupsd.conf))
(string (configuration-missing-field 'opaque-cups-configuration
'cupsd.conf))
"The contents of the @code{cupsd.conf} to use.")
(cups-files.conf
(string (cups-configuration-missing-field 'opaque-cups-configuration
'cups-files.conf))
(string (configuration-missing-field 'opaque-cups-configuration
'cups-files.conf))
"The contents of the @code{cups-files.conf} to use."))
(define %cups-activation
@ -1117,8 +991,8 @@ extensions that it uses."
extensions)))))))))
;; A little helper to make it easier to document all those fields.
(define (generate-documentation)
(define documentation
(define (generate-cups-documentation)
(generate-documentation
`((cups-configuration
,cups-configuration-fields
(files-configuration files-configuration)
@ -1132,35 +1006,5 @@ extensions that it uses."
,location-access-control-fields
(method-access-controls method-access-controls))
(operation-access-controls ,operation-access-control-fields)
(method-access-controls ,method-access-control-fields)))
(define (str x) (object->string x))
(define (generate configuration-name)
(match (assq-ref documentation configuration-name)
((fields . sub-documentation)
`((para "Available " (code ,(str configuration-name)) " fields are:")
,@(map
(lambda (f)
(let ((field-name (configuration-field-name f))
(field-type (configuration-field-type f))
(field-docs (cdr (texi-fragment->stexi
(configuration-field-documentation f))))
(default (catch #t
(configuration-field-default-value-thunk f)
(lambda _ '%invalid))))
(define (show-default? val)
(or (string? default) (number? default) (boolean? default)
(and (symbol? val) (not (eq? val '%invalid)))
(and (list? val) (and-map show-default? val))))
`(deftypevr (% (category
(code ,(str configuration-name)) " parameter")
(data-type ,(str field-type))
(name ,(str field-name)))
,@field-docs
,@(if (show-default? default)
`((para "Defaults to " (samp ,(str default)) "."))
'())
,@(append-map
generate
(or (assq-ref sub-documentation field-name) '())))))
fields)))))
(stexi->texi `(*fragment* . ,(generate 'cups-configuration))))
(method-access-controls ,method-access-control-fields))
'cups-configuration))

10
gnu/services/kerberos.scm
View File

@ -38,15 +38,17 @@
"Return a PAM service for Kerberos authentication."
(lambda (pam)
(define pam-krb5-module
#~(string-append #$(pam-krb5-configuration-pam-krb5 config) "/lib/security/pam_krb5.so"))
#~(string-append #$(pam-krb5-configuration-pam-krb5 config)
"/lib/security/pam_krb5.so"))
(let ((pam-krb5-sufficient
(pam-entry
(control "sufficient")
(module pam-krb5-module)
(arguments (list
(format #f "minimum_uid=~a"
(pam-krb5-configuration-minimum-uid config)))))))
(arguments
(list
(format #f "minimum_uid=~a"
(pam-krb5-configuration-minimum-uid config)))))))
(pam-service
(inherit pam)
(auth (cons* pam-krb5-sufficient

265
gnu/services/mail.scm
View File

@ -21,6 +21,7 @@
(define-module (gnu services mail)
#:use-module (gnu services)
#:use-module (gnu services base)
#:use-module (gnu services configuration)
#:use-module (gnu services shepherd)
#:use-module (gnu system pam)
#:use-module (gnu system shadow)
@ -30,13 +31,8 @@
#:use-module (guix records)
#:use-module (guix packages)
#:use-module (guix gexp)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (ice-9 match)
#:export (&dovecot-configuation-error
dovecot-configuration-error?
dovecot-service
#:export (dovecot-service
dovecot-service-type
dovecot-configuration
opaque-dovecot-configuration
@ -51,7 +47,12 @@
protocol-configuration
plugin-configuration
mailbox-configuration
namespace-configuration))
namespace-configuration
opensmtpd-configuration
opensmtpd-configuration?
opensmtpd-service-type
%default-opensmtpd-config-file))
;;; Commentary:
;;;
@ -60,112 +61,6 @@
;;;
;;; Code:
(define-condition-type &dovecot-configuration-error &error
dovecot-configuration-error?)
(define (dovecot-error message)
(raise (condition (&message (message message))
(&dovecot-configuration-error))))
(define (dovecot-configuration-field-error field val)
(dovecot-error
(format #f "Invalid value for field ~a: ~s" field val)))
(define (dovecot-configuration-missing-field kind field)
(dovecot-error
(format #f "~a configuration missing required field ~a" kind field)))
(define-record-type* <configuration-field>
configuration-field make-configuration-field configuration-field?
(name configuration-field-name)
(type configuration-field-type)
(getter configuration-field-getter)
(predicate configuration-field-predicate)
(serializer configuration-field-serializer)
(default-value-thunk configuration-field-default-value-thunk)
(documentation configuration-field-documentation))
(define-syntax define-configuration
(lambda (stx)
(define (id ctx part . parts)
(let ((part (syntax->datum part)))
(datum->syntax
ctx
(match parts
(() part)
(parts (symbol-append part
(syntax->datum (apply id ctx parts))))))))
(syntax-case stx ()
((_ stem (field (field-type def) doc) ...)
(with-syntax (((field-getter ...)
(map (lambda (field)
(id #'stem #'stem #'- field))
#'(field ...)))
((field-predicate ...)
(map (lambda (type)
(id #'stem type #'?))
#'(field-type ...)))
((field-serializer ...)
(map (lambda (type)
(id #'stem #'serialize- type))
#'(field-type ...))))
#`(begin
(define-record-type* #,(id #'stem #'< #'stem #'>)
stem #,(id #'stem #'make- #'stem) #,(id #'stem #'stem #'?)
(field field-getter (default def))
...)
(define #,(id #'stem #'stem #'-fields)
(list (configuration-field
(name 'field)
(type 'field-type)
(getter field-getter)
(predicate field-predicate)
(serializer field-serializer)
(default-value-thunk (lambda () def))
(documentation doc))
...))))))))
(define (serialize-configuration config fields)
(for-each (lambda (field)
((configuration-field-serializer field)
(configuration-field-name field)
((configuration-field-getter field) config)))
fields))
(define (validate-configuration config fields)
(for-each (lambda (field)
(let ((val ((configuration-field-getter field) config)))
(unless ((configuration-field-predicate field) val)
(dovecot-configuration-field-error
(configuration-field-name field) val))))
fields))
(define (validate-package field-name package)
(unless (package? package)
(dovecot-configuration-field-error field-name package)))
(define (uglify-field-name field-name)
(let ((str (symbol->string field-name)))
(string-join (string-split (if (string-suffix? "?" str)
(substring str 0 (1- (string-length str)))
str)
#\-)
"_")))
(define (serialize-package field-name val)
#f)
(define (serialize-field field-name val)
(format #t "~a=~a\n" (uglify-field-name field-name) val))
(define (serialize-string field-name val)
(serialize-field field-name val))
(define (space-separated-string-list? val)
(and (list? val)
(and-map (lambda (x)
(and (string? x) (not (string-index x #\space))))
val)))
(define (serialize-space-separated-string-list field-name val)
(serialize-field field-name (string-join val " ")))
(define (comma-separated-string-list? val)
(and (list? val)
@ -175,12 +70,6 @@
(define (serialize-comma-separated-string-list field-name val)
(serialize-field field-name (string-join val ",")))
(define (file-name? val)
(and (string? val)
(string-prefix? "/" val)))
(define (serialize-file-name field-name val)
(serialize-string field-name val))
(define (colon-separated-file-name-list? val)
(and (list? val)
;; Trailing slashes not needed and not
@ -188,9 +77,6 @@
(define (serialize-colon-separated-file-name-list field-name val)
(serialize-field field-name (string-join val ":")))
(define (serialize-boolean field-name val)
(serialize-string field-name (if val "yes" "no")))
(define (non-negative-integer? val)
(and (exact-integer? val) (not (negative? val))))
(define (serialize-non-negative-integer field-name val)
@ -271,7 +157,7 @@
(define-configuration unix-listener-configuration
(path
(file-name (dovecot-configuration-missing-field 'unix-listener 'path))
(file-name (configuration-missing-field 'unix-listener 'path))
"The file name on which to listen.")
(mode
(string "0600")
@ -290,7 +176,7 @@
(define-configuration fifo-listener-configuration
(path
(file-name (dovecot-configuration-missing-field 'fifo-listener 'path))
(file-name (configuration-missing-field 'fifo-listener 'path))
"The file name on which to listen.")
(mode
(string "0600")
@ -309,14 +195,14 @@
(define-configuration inet-listener-configuration
(protocol
(string (dovecot-configuration-missing-field 'inet-listener 'protocol))
(string (configuration-missing-field 'inet-listener 'protocol))
"The protocol to listen for.")
(address
(string "")
"The address on which to listen, or empty for all addresses.")
(port
(non-negative-integer
(dovecot-configuration-missing-field 'inet-listener 'port))
(configuration-missing-field 'inet-listener 'port))
"The port on which to listen.")
(ssl?
(boolean #t)
@ -340,7 +226,7 @@
(serialize-fifo-listener-configuration field-name val))
((inet-listener-configuration? val)
(serialize-inet-listener-configuration field-name val))
(else (dovecot-configuration-field-error field-name val))))
(else (configuration-field-error field-name val))))
(define (listener-configuration-list? val)
(and (list? val) (and-map listener-configuration? val)))
(define (serialize-listener-configuration-list field-name val)
@ -350,7 +236,7 @@
(define-configuration service-configuration
(kind
(string (dovecot-configuration-missing-field 'service 'kind))
(string (configuration-missing-field 'service 'kind))
"The service kind. Valid values include @code{director},
@code{imap-login}, @code{pop3-login}, @code{lmtp}, @code{imap},
@code{pop3}, @code{auth}, @code{auth-worker}, @code{dict},
@ -388,7 +274,7 @@ this."))
(define-configuration protocol-configuration
(name
(string (dovecot-configuration-missing-field 'protocol 'name))
(string (configuration-missing-field 'protocol 'name))
"The name of the protocol.")
(auth-socket-path
(string "/var/run/dovecot/auth-userdb")
@ -1492,8 +1378,8 @@ greyed out, instead of only later giving \"not selectable\" popup error.
"The dovecot package.")
(string
(string (dovecot-configuration-missing-field 'opaque-dovecot-configuration
'string))
(string (configuration-missing-field 'opaque-dovecot-configuration
'string))
"The contents of the @code{dovecot.conf} to use."))
(define %dovecot-accounts
@ -1629,8 +1515,8 @@ by @code{dovecot-configuration}. @var{config} may also be created by
(service dovecot-service-type config))
;; A little helper to make it easier to document all those fields.
(define (generate-documentation)
(define documentation
(define (generate-dovecot-documentation)
(generate-documentation
`((dovecot-configuration
,dovecot-configuration-fields
(dict dict-configuration)
@ -1655,39 +1541,80 @@ by @code{dovecot-configuration}. @var{config} may also be created by
,service-configuration-fields
(listeners unix-listener-configuration fifo-listener-configuration
inet-listener-configuration))
(protocol-configuration ,protocol-configuration-fields)))
(define (generate configuration-name)
(match (assq-ref documentation configuration-name)
((fields . sub-documentation)
(format #t "\nAvailable @code{~a} fields are:\n\n" configuration-name)
(for-each
(lambda (f)
(let ((field-name (configuration-field-name f))
(field-type (configuration-field-type f))
(field-docs (string-trim-both
(configuration-field-documentation f)))
(default (catch #t
(configuration-field-default-value-thunk f)
(lambda _ 'nope))))
(define (escape-chars str chars escape)
(with-output-to-string
(lambda ()
(string-for-each (lambda (c)
(when (char-set-contains? chars c)
(display escape))
(display c))
str))))
(define (show-default? val)
(or (string? default) (number? default) (boolean? default)
(and (list? val) (and-map show-default? val))))
(format #t "@deftypevr {@code{~a} parameter} ~a ~a\n~a\n"
configuration-name field-type field-name field-docs)
(when (show-default? default)
(format #t "Defaults to @samp{~a}.\n"
(escape-chars (format #f "~s" default)
(char-set #\@ #\{ #\})
#\@)))
(for-each generate (or (assq-ref sub-documentation field-name) '()))
(format #t "@end deftypevr\n\n")))
fields))))
(generate 'dovecot-configuration))
(protocol-configuration ,protocol-configuration-fields))
'dovecot-configuration))
;;;
;;; OpenSMTPD.
;;;
(define-record-type* <opensmtpd-configuration>
opensmtpd-configuration make-opensmtpd-configuration
opensmtpd-configuration?
(package opensmtpd-configuration-package
(default opensmtpd))
(config-file opensmtpd-configuration-config-file
(default %default-opensmtpd-config-file)))
(define %default-opensmtpd-config-file
(plain-file "smtpd.conf" "
listen on lo
accept from any for local deliver to mbox
accept from local for any relay
"))
(define opensmtpd-shepherd-service
(match-lambda
(($ <opensmtpd-configuration> package config-file)
(list (shepherd-service
(provision '(smtpd))
(requirement '(loopback))
(documentation "Run the OpenSMTPD daemon.")
(start (let ((smtpd (file-append package "/sbin/smtpd")))
#~(make-forkexec-constructor
(list #$smtpd "-f" #$config-file)
#:pid-file "/var/run/smtpd.pid")))
(stop #~(make-kill-destructor)))))))
(define %opensmtpd-accounts
(list (user-group
(name "smtpq")
(system? #t))
(user-account
(name "smtpd")
(group "nogroup")
(system? #t)
(comment "SMTP Daemon")
(home-directory "/var/empty")
(shell (file-append shadow "/sbin/nologin")))
(user-account
(name "smtpq")
(group "smtpq")
(system? #t)
(comment "SMTPD Queue")
(home-directory "/var/empty")
(shell (file-append shadow "/sbin/nologin")))))
(define opensmtpd-activation
(match-lambda
(($ <opensmtpd-configuration> package config-file)
(let ((smtpd (file-append package "/sbin/smtpd")))
#~(begin
;; Create mbox and spool directories.
(mkdir-p "/var/mail")
(mkdir-p "/var/spool/smtpd")
(chmod "/var/spool/smtpd" #o711))))))
(define opensmtpd-service-type
(service-type
(name 'opensmtpd)
(extensions
(list (service-extension account-service-type
(const %opensmtpd-accounts))
(service-extension activation-service-type
opensmtpd-activation)
(service-extension profile-service-type
(compose list opensmtpd-configuration-package))
(service-extension shepherd-root-service-type
opensmtpd-shepherd-service)))))

3
gnu/system/examples/desktop.tmpl
View File

@ -4,7 +4,7 @@
(use-modules (gnu) (gnu system nss))
(use-service-modules desktop)
(use-package-modules certs)
(use-package-modules certs gnome)
(operating-system
(host-name "antelope")
@ -42,6 +42,7 @@
;; This is where we specify system-wide packages.
(packages (cons* nss-certs ;for HTTPS access
gvfs ;for user mounts
%base-packages))
;; Add GNOME and/or Xfce---we can choose at the log-in

159
gnu/tests/mail.scm Normal file
View File

@ -0,0 +1,159 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Sou Bunnbu <iyzsong@member.fsf.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu tests mail)
#:use-module (gnu tests)
#:use-module (gnu system)
#:use-module (gnu system file-systems)
#:use-module (gnu system grub)
#:use-module (gnu system vm)
#:use-module (gnu services)
#:use-module (gnu services base)
#:use-module (gnu services mail)
#:use-module (gnu services networking)
#:use-module (guix gexp)
#:use-module (guix monads)
#:use-module (guix store)
#:export (%test-opensmtpd))
(define %opensmtpd-os
(operating-system
(host-name "komputilo")
(timezone "Europe/Berlin")
(locale "en_US.UTF-8")
(bootloader (grub-configuration (device #f)))
(file-systems %base-file-systems)
(firmware '())
(services (cons*
(dhcp-client-service)
(service opensmtpd-service-type
(opensmtpd-configuration
(config-file
(plain-file "smtpd.conf" "
listen on 0.0.0.0
accept from any for local deliver to mbox
"))))
%base-services))))
(define (run-opensmtpd-test)
"Return a test of an OS running OpenSMTPD service."
(mlet* %store-monad ((command (system-qemu-image/shared-store-script
(marionette-operating-system
%opensmtpd-os
#:imported-modules '((gnu services herd)))
#:graphic? #f)))
(define test
(with-imported-modules '((gnu build marionette))
#~(begin
(use-modules (rnrs base)
(srfi srfi-64)
(ice-9 rdelim)
(ice-9 regex)
(gnu build marionette))
(define marionette
(make-marionette
;; Enable TCP forwarding of the guest's port 25.
'(#$command "-net" "user,hostfwd=tcp::1025-:25")))
(define (read-reply-code port)
"Read a SMTP reply from PORT and return its reply code."
(let* ((line (read-line port))
(mo (string-match "([0-9]+)([ -]).*" line))
(code (string->number (match:substring mo 1)))
(finished? (string= " " (match:substring mo 2))))
(if finished?
code
(read-reply-code port))))
(mkdir #$output)
(chdir #$output)
(test-begin "opensmptd")
(test-assert "service is running"
(marionette-eval
'(begin
(use-modules (gnu services herd))
(start-service 'smtpd)
#t)
marionette))
(test-assert "mbox is empty"
(marionette-eval
'(and (file-exists? "/var/mail")
(not (file-exists? "/var/mail/root")))
marionette))
(test-eq "accept an email"
#t
(let* ((smtp (socket AF_INET SOCK_STREAM 0))
(addr (make-socket-address AF_INET INADDR_LOOPBACK 1025)))
(connect smtp addr)
;; Be greeted.
(read-reply-code smtp) ;220
;; Greet the server.
(write-line "EHLO somehost" smtp)
(read-reply-code smtp) ;250
;; Set sender email.
(write-line "MAIL FROM: <someone>" smtp)
(read-reply-code smtp) ;250
;; Set recipient email.
(write-line "RCPT TO: <root>" smtp)
(read-reply-code smtp) ;250
;; Send message.
(write-line "DATA" smtp)
(read-reply-code smtp) ;354
(write-line "Subject: Hello" smtp)
(newline smtp)
(write-line "Nice to meet you!" smtp)
(write-line "." smtp)
(read-reply-code smtp) ;250
;; Say goodbye.
(write-line "QUIT" smtp)
(read-reply-code smtp) ;221
(close smtp)
#t))
(test-assert "mail arrived"
(marionette-eval
'(begin
(use-modules (ice-9 popen)
(ice-9 rdelim))
(define (queue-empty?)
(eof-object?
(read-line
(open-input-pipe "smtpctl show queue"))))
(let wait ()
(if (queue-empty?)
(file-exists? "/var/mail/root")
(begin (sleep 1) (wait)))))
marionette))
(test-end)
(exit (= (test-runner-fail-count (test-runner-current)) 0)))))
(gexp->derivation "opensmtpd-test" test)))
(define %test-opensmtpd
(system-test
(name "opensmtpd")
(description "Send an email to a running OpenSMTPD server.")
(value (run-opensmtpd-test))))

2
guix/build/pull.scm
View File

@ -84,7 +84,7 @@ containing the source code. Write any debugging output to DEBUG-PORT."
(("@GZIP@") (string-append gzip "/bin/gzip"))
(("@BZIP2@") (string-append bzip2 "/bin/bzip2"))
(("@XZ@") (string-append xz "/bin/xz"))
(("@NIX_INSTANTIATE@") "")) ;remnants from the past
(("@NIX_INSTANTIATE@") "nix-instantiate")) ;for (guix import nix)
;; Augment the search path so Scheme code can be compiled.
(set! %load-path (cons out %load-path))

3
guix/gnu-maintenance.scm
View File

@ -525,7 +525,8 @@ elpa.gnu.org, and all the GNOME packages."
(let ((uri (string->uri (origin-uri (package-source package)))))
(false-if-ftp-error
(latest-ftp-release
(package-name package)
(or (assoc-ref (package-properties package) 'upstream-name)
(package-name package))
#:server "mirrors.mit.edu"
#:directory
(string-append "/kde" (dirname (dirname (uri-path uri))))

602
guix/scripts/offload.scm
View File

@ -17,6 +17,13 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix scripts offload)
#:use-module (ssh key)
#:use-module (ssh auth)
#:use-module (ssh session)
#:use-module (ssh channel)
#:use-module (ssh popen)
#:use-module (ssh dist)
#:use-module (ssh dist node)
#:use-module (guix config)
#:use-module (guix records)
#:use-module (guix store)
@ -65,14 +72,15 @@
(system build-machine-system) ; string
(user build-machine-user) ; string
(private-key build-machine-private-key ; file name
(default (user-lsh-private-key)))
(default (user-openssh-private-key)))
(host-key build-machine-host-key) ; string
(daemon-socket build-machine-daemon-socket ; string
(default "/var/guix/daemon-socket/socket"))
(parallel-builds build-machine-parallel-builds ; number
(default 1))
(speed build-machine-speed ; inexact real
(default 1.0))
(features build-machine-features ; list of strings
(default '()))
(ssh-options build-machine-ssh-options ; list of strings
(default '())))
(define-record-type* <build-requirements>
@ -86,19 +94,11 @@
;; File that lists machines available as build slaves.
(string-append %config-directory "/machines.scm"))
(define %lsh-command
"lsh")
(define %lshg-command
;; FIXME: 'lshg' fails to pass large amounts of data, see
;; <http://lists.lysator.liu.se/pipermail/lsh-bugs/2014q1/000639.html>.
"lsh")
(define (user-lsh-private-key)
"Return the user's default lsh private key, or #f if it could not be
(define (user-openssh-private-key)
"Return the user's default SSH private key, or #f if it could not be
determined."
(and=> (getenv "HOME")
(cut string-append <> "/.lsh/identity")))
(cut string-append <> "/.ssh/id_rsa")))
(define %user-module
;; Module in which the machine description file is loaded.
@ -134,81 +134,120 @@ determined."
(leave (_ "failed to load machine file '~a': ~s~%")
file args))))))
;;; FIXME: The idea was to open the connection to MACHINE once for all, but
;;; lshg is currently non-functional.
;; (define (open-ssh-gateway machine)
;; "Initiate an SSH connection gateway to MACHINE, and return the PID of the
;; running lsh gateway upon success, or #f on failure."
;; (catch 'system-error
;; (lambda ()
;; (let* ((port (open-pipe* OPEN_READ %lsh-command
;; "-l" (build-machine-user machine)
;; "-i" (build-machine-private-key machine)
;; ;; XXX: With lsh 2.1, passing '--write-pid'
;; ;; last causes the PID not to be printed.
;; "--write-pid" "--gateway" "--background"
;; (build-machine-name machine)))
;; (line (read-line port))
;; (status (close-pipe port)))
;; (if (zero? status)
;; (let ((pid (string->number line)))
;; (if (integer? pid)
;; pid
;; (begin
;; (warning (_ "'~a' did not write its PID on stdout: ~s~%")
;; %lsh-command line)
;; #f)))
;; (begin
;; (warning (_ "failed to initiate SSH connection to '~a':\
;; '~a' exited with ~a~%")
;; (build-machine-name machine)
;; %lsh-command
;; (status:exit-val status))
;; #f))))
;; (lambda args
;; (leave (_ "failed to execute '~a': ~a~%")
;; %lsh-command (strerror (system-error-errno args))))))
(define (host-key->type+key host-key)
"Destructure HOST-KEY, an OpenSSH host key string, and return two values:
its key type as a symbol, and the actual base64-encoded string."
(define (type->symbol type)
(and (string-prefix? "ssh-" type)
(string->symbol (string-drop type 4))))
(define-syntax with-error-to-port
(syntax-rules ()
((_ port exp0 exp ...)
(let ((new port)
(old (current-error-port)))
(dynamic-wind
(lambda ()
(set-current-error-port new))
(lambda ()
exp0 exp ...)
(lambda ()
(set-current-error-port old)))))))
(match (string-tokenize host-key)
((type key _)
(values (type->symbol type) key))
((type key)
(values (type->symbol type) key))))
(define* (remote-pipe machine mode command
#:key (error-port (current-error-port)) (quote? #t))
"Run COMMAND (a string list) on MACHINE, assuming an lsh gateway has been
set up. When QUOTE? is true, perform shell-quotation of all the elements of
COMMAND. Return either a pipe opened with MODE, or #f if the lsh client could
not be started."
(define (shell-quote str)
;; Sort-of shell-quote STR so it can be passed as an argument to the
;; shell.
(with-output-to-string
(lambda ()
(write str))))
(define (private-key-from-file* file)
"Like 'private-key-from-file', but raise an error that 'with-error-handling'
can interpret meaningfully."
(catch 'guile-ssh-error
(lambda ()
(private-key-from-file file))
(lambda (key proc str . rest)
(raise (condition
(&message (message (format #f (_ "failed to load SSH \
private key from '~a': ~a")
file str))))))))
;; Let the child inherit ERROR-PORT.
(with-error-to-port error-port
(apply open-pipe* mode %lshg-command
"-l" (build-machine-user machine)
"-p" (number->string (build-machine-port machine))
(define (open-ssh-session machine)
"Open an SSH session for MACHINE and return it. Throw an error on failure."
(let ((private (private-key-from-file* (build-machine-private-key machine)))
(public (public-key-from-file
(string-append (build-machine-private-key machine)
".pub")))
(session (make-session #:user (build-machine-user machine)
#:host (build-machine-name machine)
#:port (build-machine-port machine)
#:timeout 5 ;seconds
;; #:log-verbosity 'protocol
#:identity (build-machine-private-key machine)
;; XXX: Remove '-i' when %LSHG-COMMAND really is lshg.
"-i" (build-machine-private-key machine)
;; We need lightweight compression when
;; exchanging full archives.
#:compression "zlib"
#:compression-level 3)))
(connect! session)
(append (build-machine-ssh-options machine)
(list (build-machine-name machine))
(if quote?
(map shell-quote command)
command)))))
;; Authenticate the server. XXX: Guile-SSH 0.10.1 doesn't know about
;; ed25519 keys and 'get-key-type' returns #f in that case.
(let-values (((server) (get-server-public-key session))
((type key) (host-key->type+key
(build-machine-host-key machine))))
(unless (and (or (not (get-key-type server))
(eq? (get-key-type server) type))
(string=? (public-key->string server) key))
;; Key mismatch: something's wrong. XXX: It could be that the server
;; provided its Ed25519 key when we where expecting its RSA key.
(leave (_ "server at '~a' returned host key '~a' of type '~a' \
instead of '~a' of type '~a'~%")
(build-machine-name machine)
(public-key->string server) (get-key-type server)
key type)))
(let ((auth (userauth-public-key! session private)))
(unless (eq? 'success auth)
(disconnect! session)
(leave (_ "SSH public key authentication failed for '~a': ~a~%")
(build-machine-name machine) (get-error session))))
session))
(define* (connect-to-remote-daemon session
#:optional
(socket-name "/var/guix/daemon-socket/socket"))
"Connect to the remote build daemon listening on SOCKET-NAME over SESSION,
an SSH session. Return a <nix-server> object."
(define redirect
;; Code run in SESSION to redirect the remote process' stdin/stdout to the
;; daemon's socket, à la socat. The SSH protocol supports forwarding to
;; Unix-domain sockets but libssh doesn't have an API for that, hence this
;; hack.
`(begin
(use-modules (ice-9 match) (rnrs io ports))
(let ((sock (socket AF_UNIX SOCK_STREAM 0))
(stdin (current-input-port))
(stdout (current-output-port)))
(setvbuf stdin _IONBF)
(setvbuf stdout _IONBF)
(connect sock AF_UNIX ,socket-name)
(let loop ()
(match (select (list stdin sock) '() (list stdin stdout sock))
((reads writes ())
(when (memq stdin reads)
(match (get-bytevector-some stdin)
((? eof-object?)
(primitive-exit 0))
(bv
(put-bytevector sock bv))))
(when (memq sock reads)
(match (get-bytevector-some sock)
((? eof-object?)
(primitive-exit 0))
(bv
(put-bytevector stdout bv))))
(loop))
(_
(primitive-exit 1)))))))
(let ((channel
(open-remote-pipe* session OPEN_BOTH
;; Sort-of shell-quote REDIRECT.
"guile" "-c"
(object->string
(object->string redirect)))))
(open-connection #:port channel)))
;;;
@ -299,113 +338,6 @@ hook."
(set-port-revealed! port 1)
port))
(define %gc-root-file
;; File name of the temporary GC root we install.
(format #f "offload-~a-~a" (gethostname) (getpid)))
(define (register-gc-root file machine)
"Mark FILE, a store item, as a garbage collector root on MACHINE."
(define script
`(begin
(use-modules (guix config))
;; Note: we can't use 'add-indirect-root' because dangling links under
;; gcroots/auto are automatically deleted by the GC. This strategy
;; doesn't have this problem, but it requires write access to that
;; directory.
(let ((root-directory (string-append %state-directory
"/gcroots/tmp")))
(catch 'system-error
(lambda ()
(mkdir root-directory))
(lambda args
(unless (= EEXIST (system-error-errno args))
(error "failed to create remote GC root directory"
root-directory (system-error-errno args)))))
(catch 'system-error
(lambda ()
(symlink ,file
(string-append root-directory "/" ,%gc-root-file)))
(lambda args
;; If FILE already exists, we can assume that either it's a stale
;; reference (which is fine), or another process is already
;; building the derivation represented by FILE (which is fine
;; too.) Thus, do nothing in that case.
(unless (= EEXIST (system-error-errno args))
(apply throw args)))))))
(let ((pipe (remote-pipe machine OPEN_READ
`("guile" "-c" ,(object->string script)))))
(read-string pipe)
(let ((status (close-pipe pipe)))
(unless (zero? status)
;; Better be safe than sorry: if we ignore the error here, then FILE
;; may be GC'd just before we start using it.
(leave (_ "failed to register GC root for '~a' on '~a' (status: ~a)~%")
file (build-machine-name machine) status)))))
(define (remove-gc-roots machine)
"Remove from MACHINE the GC roots previously installed with
'register-gc-root'."
(define script
`(begin
(use-modules (guix config) (ice-9 ftw)
(srfi srfi-1) (srfi srfi-26))
(let ((root-directory (string-append %state-directory
"/gcroots/tmp")))
(false-if-exception
(delete-file
(string-append root-directory "/" ,%gc-root-file)))
;; These ones were created with 'guix build -r' (there can be more
;; than one in case of multiple-output derivations.)
(let ((roots (filter (cut string-prefix? ,%gc-root-file <>)
(scandir "."))))
(for-each (lambda (file)
(false-if-exception (delete-file file)))
roots)))))
(let ((pipe (remote-pipe machine OPEN_READ
`("guile" "-c" ,(object->string script)))))
(read-string pipe)
(close-pipe pipe)))
(define* (offload drv machine
#:key print-build-trace? (max-silent-time 3600)
build-timeout (log-port (build-log-port)))
"Perform DRV on MACHINE, assuming DRV and its prerequisites are available
there, and write the build log to LOG-PORT. Return the exit status."
(format (current-error-port) "offloading '~a' to '~a'...~%"
(derivation-file-name drv) (build-machine-name machine))
(format (current-error-port) "@ build-remote ~a ~a~%"
(derivation-file-name drv) (build-machine-name machine))
;; Normally DRV has already been protected from GC when it was transferred.
;; The '-r' flag below prevents the build result from being GC'd.
(let ((pipe (remote-pipe machine OPEN_READ
`("guix" "build"
"-r" ,%gc-root-file
,(format #f "--max-silent-time=~a"
max-silent-time)
,@(if build-timeout
(list (format #f "--timeout=~a"
build-timeout))
'())
,(derivation-file-name drv))
;; Since 'guix build' writes the build log to its
;; stderr, everything will go directly to LOG-PORT.
#:error-port log-port)))
(let loop ((line (read-line pipe)))
(unless (eof-object? line)
(display line log-port)
(newline log-port)
(loop (read-line pipe))))
(close-pipe pipe)))
(define* (transfer-and-offload drv machine
#:key
(inputs '())
@ -416,120 +348,131 @@ there, and write the build log to LOG-PORT. Return the exit status."
"Offload DRV to MACHINE. Prior to the actual offloading, transfer all of
INPUTS to MACHINE; if building DRV succeeds, retrieve all of OUTPUTS from
MACHINE."
(when (begin
(register-gc-root (derivation-file-name drv) machine)
(send-files (cons (derivation-file-name drv) inputs)
machine))
(let ((status (offload drv machine
#:print-build-trace? print-build-trace?
#:max-silent-time max-silent-time
#:build-timeout build-timeout)))
(if (zero? status)
(begin
(retrieve-files outputs machine)
(remove-gc-roots machine)
(format (current-error-port)
"done with offloaded '~a'~%"
(derivation-file-name drv)))
(begin
(remove-gc-roots machine)
(format (current-error-port)
"derivation '~a' offloaded to '~a' failed \
with exit code ~a~%"
(derivation-file-name drv)
(build-machine-name machine)
(status:exit-val status))
(define session
(open-ssh-session machine))
;; Use exit code 100 for a permanent build failure. The daemon
;; interprets other non-zero codes as transient build failures.
(primitive-exit 100))))))
(define store
(connect-to-remote-daemon session
(build-machine-daemon-socket machine)))
(define (send-files files machine)
"Send the subset of FILES that's missing to MACHINE's store. Return #t on
success, #f otherwise."
(define (missing-files files)
;; Return the subset of FILES not already on MACHINE.
(let*-values (((files)
(format #f "~{~a~%~}" files))
((missing pids)
(filtered-port
(append (list (which %lshg-command)
"-l" (build-machine-user machine)
"-p" (number->string
(build-machine-port machine))
"-i" (build-machine-private-key machine))
(build-machine-ssh-options machine)
(cons (build-machine-name machine)
'("guix" "archive" "--missing")))
(open-input-string files)))
((result)
(read-string missing)))
(for-each waitpid pids)
(string-tokenize result)))
(set-build-options store
#:print-build-trace print-build-trace?
#:max-silent-time max-silent-time
#:timeout build-timeout)
;; Protect DRV from garbage collection.
(add-temp-root store (derivation-file-name drv))
(send-files (cons (derivation-file-name drv) inputs)
store)
(format (current-error-port) "offloading '~a' to '~a'...~%"
(derivation-file-name drv) (build-machine-name machine))
(format (current-error-port) "@ build-remote ~a ~a~%"
(derivation-file-name drv) (build-machine-name machine))
(guard (c ((nix-protocol-error? c)
(format (current-error-port)
(_ "derivation '~a' offloaded to '~a' failed: ~a~%")
(derivation-file-name drv)
(build-machine-name machine)
(nix-protocol-error-message c))
;; Use exit code 100 for a permanent build failure. The daemon
;; interprets other non-zero codes as transient build failures.
(primitive-exit 100)))
(build-derivations store (list drv)))
(retrieve-files outputs store)
(format (current-error-port) "done with offloaded '~a'~%"
(derivation-file-name drv)))
(define (store-import-channel session)
"Return an output port to which archives to be exported to SESSION's store
can be written."
;; Using the 'import-paths' RPC on a remote store would be slow because it
;; makes a round trip every time 32 KiB have been transferred. This
;; procedure instead opens a separate channel to use the remote
;; 'import-paths' procedure, which consumes all the data in a single round
;; trip.
(define import
`(begin
(use-modules (guix))
(with-store store
(setvbuf (current-input-port) _IONBF)
(import-paths store (current-input-port)))))
(open-remote-output-pipe session
(string-join
`("guile" "-c"
,(object->string
(object->string import))))))
(define (store-export-channel session files)
"Return an input port from which an export of FILES from SESSION's store can
be read."
;; Same as above: this is more efficient than calling 'export-paths' on a
;; remote store.
(define export
`(begin
(use-modules (guix))
(with-store store
(setvbuf (current-output-port) _IONBF)
(export-paths store ',files (current-output-port)))))
(open-remote-input-pipe session
(string-join
`("guile" "-c"
,(object->string
(object->string export))))))
(define (send-files files remote)
"Send the subset of FILES that's missing to REMOTE, a remote store."
(with-store store
(guard (c ((nix-protocol-error? c)
(warning (_ "failed to export files for '~a': ~s~%")
(build-machine-name machine)
c)
#f))
;; Compute the subset of FILES missing on SESSION, and send them in
;; topologically sorted order so that they can actually be imported.
(let* ((sorted (topologically-sorted store files))
(session (channel-get-session (nix-server-socket remote)))
(node (make-node session))
(missing (node-eval node
`(begin
(use-modules (guix)
(srfi srfi-1) (srfi srfi-26))
;; Compute the subset of FILES missing on MACHINE, and send them in
;; topologically sorted order so that they can actually be imported.
;;
;; To reduce load on the machine that's offloading (since it's typically
;; already quite busy, see hydra.gnu.org), compress with gzip rather
;; than xz: For a compression ratio 2 times larger, it is 20 times
;; faster.
(let* ((files (missing-files (topologically-sorted store files)))
(pipe (remote-pipe machine OPEN_WRITE
'("gzip" "-dc" "|"
"guix" "archive" "--import")
#:quote? #f)))
(format #t (_ "sending ~a store files to '~a'...~%")
(length files) (build-machine-name machine))
(call-with-compressed-output-port 'gzip pipe
(lambda (compressed)
(catch 'system-error
(lambda ()
(export-paths store files compressed))
(lambda args
(warning (_ "failed while exporting files to '~a': ~a~%")
(build-machine-name machine)
(strerror (system-error-errno args))))))
#:options '("--fast"))
(with-store store
(remove (cut valid-path? store <>)
',sorted)))))
(port (store-import-channel session)))
(format #t (_ "sending ~a store files to '~a'...~%")
(length missing) (session-get session 'host))
;; Wait for the 'lsh' process to complete.
(zero? (close-pipe pipe))))))
(export-paths store missing port)
(define (retrieve-files files machine)
"Retrieve FILES from MACHINE's store, and import them."
(define host
(build-machine-name machine))
;; Tell the remote process that we're done. (In theory the
;; end-of-archive mark of 'export-paths' would be enough, but in
;; practice it's not.)
(channel-send-eof port)
(let ((pipe (remote-pipe machine OPEN_READ
`("guix" "archive" "--export" ,@files
"|" "xz" "-c")
#:quote? #f)))
(and pipe
(with-store store
(guard (c ((nix-protocol-error? c)
(warning (_ "failed to import files from '~a': ~s~%")
host c)
#f))
(format (current-error-port) "retrieving ~a files from '~a'...~%"
(length files) host)
;; Wait for completion of the remote process.
(let ((result (zero? (channel-get-exit-status port))))
(close-port port)
result))))
;; We cannot use the 'import-paths' RPC here because we already
;; hold the locks for FILES.
(call-with-decompressed-port 'xz pipe
(lambda (decompressed)
(restore-file-set decompressed
#:log-port (current-error-port)
#:lock? #f)))
(define (retrieve-files files remote)
"Retrieve FILES from SESSION's store, and import them."
(let* ((session (channel-get-session (nix-server-socket remote)))
(host (session-get session 'host))
(port (store-export-channel session files)))
(format #t (_ "retrieving ~a files from '~a'...~%")
(length files) host)
;; Wait for the 'lsh' process to complete.
(zero? (close-pipe pipe)))))))
;; We cannot use the 'import-paths' RPC here because we already
;; hold the locks for FILES.
(let ((result (restore-file-set port
#:log-port (current-error-port)
#:lock? #f)))
(close-port port)
result)))
;;;
@ -547,13 +490,12 @@ success, #f otherwise."
(define (machine-load machine)
"Return the load of MACHINE, divided by the number of parallel builds
allowed on MACHINE."
(let* ((pipe (remote-pipe machine OPEN_READ `("cat" "/proc/loadavg")))
(line (read-line pipe))
(status (close-pipe pipe)))
(unless (eqv? 0 (status:exit-val status))
(warning (_ "failed to obtain load of '~a': SSH client exited with ~a~%")
(build-machine-name machine)
(status:exit-val status)))
;; Note: This procedure is costly since it creates a new SSH session.
(let* ((session (open-ssh-session machine))
(pipe (open-remote-pipe* session OPEN_READ
"cat" "/proc/loadavg"))
(line (read-line pipe)))
(close-port pipe)
(if (eof-object? line)
+inf.0 ;MACHINE does not respond, so assume it is infinitely loaded
@ -569,17 +511,6 @@ allowed on MACHINE."
(_
+inf.0))))) ;something's fishy about MACHINE, so avoid it
(define (machine-power-factor m)
"Return a factor that aggregates the speed and load of M. The higher the
better."
(/ (build-machine-speed m)
(+ 1 (machine-load m))))
(define (machine-less-loaded-or-faster? m1 m2)
"Return #t if M1 is either less loaded or faster than M2. (This relation
defines a total order on machines.)"
(> (machine-power-factor m1) (machine-power-factor m2)))
(define (machine-lock-file machine hint)
"Return the name of MACHINE's lock file for HINT."
(string-append %state-directory "/offload/"
@ -607,29 +538,39 @@ defines a total order on machines.)"
;; 5. Release the global machine-choice lock.
(with-file-lock (machine-choice-lock-file)
(define machines+slots
(define machines+slots+loads
(filter-map (lambda (machine)
;; Call 'machine-load' from here to make sure it is called
;; only once per machine (it is expensive).
(let ((slot (acquire-build-slot machine)))
(and slot (list machine slot))))
(and slot
(list machine slot (machine-load machine)))))
machines))
(define (undecorate pred)
(lambda (a b)
(match a
((machine1 slot1)
((machine1 slot1 load1)
(match b
((machine2 slot2)
(pred machine1 machine2)))))))
((machine2 slot2 load2)
(pred machine1 load1 machine2 load2)))))))
(let loop ((machines+slots
(sort machines+slots
(define (machine-less-loaded-or-faster? m1 l1 m2 l2)
;; Return #t if M1 is either less loaded or faster than M2, with L1
;; being the load of M1 and L2 the load of M2. (This relation defines a
;; total order on machines.)
(> (/ (build-machine-speed m1) (+ 1 l1))
(/ (build-machine-speed m2) (+ 1 l2))))
(let loop ((machines+slots+loads
(sort machines+slots+loads
(undecorate machine-less-loaded-or-faster?))))
(match machines+slots
(((best slot) others ...)
(match machines+slots+loads
(((best slot load) others ...)
;; Return the best machine unless it's already overloaded.
(if (< (machine-load best) 2.)
(if (< load 2.)
(match others
(((machines slots) ...)
(((machines slots loads) ...)
;; Release slots from the uninteresting machines.
(for-each release-build-slot slots)
@ -675,17 +616,6 @@ defines a total order on machines.)"
;; Not now, all the machines are busy.
(display "# postpone\n")))))))
(define-syntax-rule (with-nar-error-handling body ...)
"Execute BODY with any &nar-error suitably reported to the user."
(guard (c ((nar-error? c)
(let ((file (nar-error-file c)))
(if (condition-has-type? c &message)
(leave (_ "while importing file '~a': ~a~%")
file (gettext (condition-message c)))
(leave (_ "failed to import file '~a'~%")
file)))))
body ...))
;;;
;;; Entry point.
@ -716,7 +646,7 @@ defines a total order on machines.)"
(cond ((regexp-exec request-line-rx line)
=>
(lambda (match)
(with-nar-error-handling
(with-error-handling
(process-request (equal? (match:substring match 1) "1")
(match:substring match 2) ; system
(call-with-input-file

96
guix/scripts/refresh.scm
View File

@ -208,7 +208,7 @@ unavailable optional dependencies such as Guile-JSON."
((guix import gem) => %gem-updater)
((guix import github) => %github-updater)))
(define (lookup-updater name)
(define (lookup-updater-by-name name)
"Return the updater called NAME."
(or (find (lambda (updater)
(eq? name (upstream-updater-name updater)))
@ -225,31 +225,60 @@ unavailable optional dependencies such as Guile-JSON."
%updaters)
(exit 0))
(define (warn-no-updater package)
(format (current-error-port)
(_ "~a: warning: no updater for ~a~%")
(location->string (package-location package))
(package-name package)))
(define* (update-package store package updaters
#:key (key-download 'interactive))
#:key (key-download 'interactive) warn?)
"Update the source file that defines PACKAGE with the new version.
KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
values: 'interactive' (default), 'always', and 'never'."
(let-values (((version tarball)
(package-update store package updaters
#:key-download key-download))
((loc)
(or (package-field-location package 'version)
(package-location package))))
(when version
(if (and=> tarball file-exists?)
(begin
(format (current-error-port)
(_ "~a: ~a: updating from version ~a to version ~a...~%")
(location->string loc)
(package-name package)
(package-version package) version)
(let ((hash (call-with-input-file tarball
port-sha256)))
(update-package-source package version hash)))
(warning (_ "~a: version ~a could not be \
values: 'interactive' (default), 'always', and 'never'. When WARN? is true,
warn about packages that have no matching updater."
(if (lookup-updater package updaters)
(let-values (((version tarball)
(package-update store package updaters
#:key-download key-download))
((loc)
(or (package-field-location package 'version)
(package-location package))))
(when version
(if (and=> tarball file-exists?)
(begin
(format (current-error-port)
(_ "~a: ~a: updating from version ~a to version ~a...~%")
(location->string loc)
(package-name package)
(package-version package) version)
(let ((hash (call-with-input-file tarball
port-sha256)))
(update-package-source package version hash)))
(warning (_ "~a: version ~a could not be \
downloaded and authenticated; not updating~%")
(package-name package) version)))))
(package-name package) version))))
(when warn?
(warn-no-updater package))))
(define* (check-for-package-update package #:key warn?)
"Check whether an update is available for PACKAGE and print a message. When
WARN? is true and no updater exists for PACKAGE, print a warning."
(match (package-latest-release package %updaters)
((? upstream-source? source)
(when (version>? (upstream-source-version source)
(package-version package))
(let ((loc (or (package-field-location package 'version)
(package-location package))))
(format (current-error-port)
(_ "~a: ~a would be upgraded from ~a to ~a~%")
(location->string loc)
(package-name package) (package-version package)
(upstream-source-version source)))))
(#f
(when warn?
(warn-no-updater package)))))
;;;
@ -312,7 +341,7 @@ dependent packages are rebuilt: ~{~a~^ ~}~%"
;; Return the list of updaters to use.
(match (filter-map (match-lambda
(('updaters . names)
(map lookup-updater names))
(map lookup-updater-by-name names))
(_ #f))
opts)
(()
@ -360,6 +389,12 @@ update would trigger a complete rebuild."
(updaters (options->updaters opts))
(list-dependent? (assoc-ref opts 'list-dependent?))
(key-download (assoc-ref opts 'key-download))
;; Warn about missing updaters when a package is explicitly given on
;; the command line.
(warn? (or (assoc-ref opts 'argument)
(assoc-ref opts 'expression)))
(packages
(match (filter-map (match-lambda
(('argument . spec)
@ -397,22 +432,13 @@ update would trigger a complete rebuild."
(%gpg-command))))
(for-each
(cut update-package store <> updaters
#:key-download key-download)
#:key-download key-download
#:warn? warn?)
packages)
(with-monad %store-monad
(return #t))))
(else
(for-each (lambda (package)
(match (package-update-path package updaters)
((? upstream-source? source)
(let ((loc (or (package-field-location package 'version)
(package-location package))))
(format (current-error-port)
(_ "~a: ~a would be upgraded from ~a to ~a~%")
(location->string loc)
(package-name package) (package-version package)
(upstream-source-version source))))
(#f #f)))
(for-each (cut check-for-package-update <> #:warn? warn?)
packages)
(with-monad %store-monad
(return #t)))))))))

58
guix/store.scm
View File

@ -345,50 +345,58 @@
(message nix-protocol-error-message)
(status nix-protocol-error-status))
(define* (open-connection #:optional (file (%daemon-socket-file))
#:key (reserve-space? #t) cpu-affinity)
"Connect to the daemon over the Unix-domain socket at FILE. When
RESERVE-SPACE? is true, instruct it to reserve a little bit of extra space on
the file system so that the garbage collector can still operate, should the
disk become full. When CPU-AFFINITY is true, it must be an integer
corresponding to an OS-level CPU number to which the daemon's worker process
for this connection will be pinned. Return a server object."
(define (open-unix-domain-socket file)
"Connect to the Unix-domain socket at FILE and return it. Raise a
'&nix-connection-error' upon error."
(let ((s (with-fluids ((%default-port-encoding #f))
;; This trick allows use of the `scm_c_read' optimization.
(socket PF_UNIX SOCK_STREAM 0)))
(a (make-socket-address PF_UNIX file)))
(catch 'system-error
(cut connect s a)
(lambda ()
(connect s a)
s)
(lambda args
;; Translate the error to something user-friendly.
(let ((errno (system-error-errno args)))
(raise (condition (&nix-connection-error
(file file)
(errno errno)))))))
(errno errno)))))))))
(write-int %worker-magic-1 s)
(let ((r (read-int s)))
(define* (open-connection #:optional (file (%daemon-socket-file))
#:key port (reserve-space? #t) cpu-affinity)
"Connect to the daemon over the Unix-domain socket at FILE, or, if PORT is
not #f, use it as the I/O port over which to communicate to a build daemon.
When RESERVE-SPACE? is true, instruct it to reserve a little bit of extra
space on the file system so that the garbage collector can still operate,
should the disk become full. When CPU-AFFINITY is true, it must be an integer
corresponding to an OS-level CPU number to which the daemon's worker process
for this connection will be pinned. Return a server object."
(let ((port (or port (open-unix-domain-socket file))))
(write-int %worker-magic-1 port)
(let ((r (read-int port)))
(and (eqv? r %worker-magic-2)
(let ((v (read-int s)))
(let ((v (read-int port)))
(and (eqv? (protocol-major %protocol-version)
(protocol-major v))
(begin
(write-int %protocol-version s)
(write-int %protocol-version port)
(when (>= (protocol-minor v) 14)
(write-int (if cpu-affinity 1 0) s)
(write-int (if cpu-affinity 1 0) port)
(when cpu-affinity
(write-int cpu-affinity s)))
(write-int cpu-affinity port)))
(when (>= (protocol-minor v) 11)
(write-int (if reserve-space? 1 0) s))
(let ((s (%make-nix-server s
(protocol-major v)
(protocol-minor v)
(make-hash-table 100)
(make-hash-table 100))))
(let loop ((done? (process-stderr s)))
(or done? (process-stderr s)))
s))))))))
(write-int (if reserve-space? 1 0) port))
(let ((conn (%make-nix-server port
(protocol-major v)
(protocol-minor v)
(make-hash-table 100)
(make-hash-table 100))))
(let loop ((done? (process-stderr conn)))
(or done? (process-stderr conn)))
conn))))))))
(define (close-connection server)
"Close the connection to SERVER."

30
guix/upstream.scm
View File

@ -49,8 +49,11 @@
upstream-updater-predicate
upstream-updater-latest
lookup-updater
download-tarball
package-update-path
package-latest-release
package-latest-release*
package-update
update-package-source))
@ -127,17 +130,24 @@ them matches."
(and (pred package) latest)))
updaters))
(define (package-update-path package updaters)
(define (package-latest-release package updaters)
"Return an upstream source to update PACKAGE, a <package> object, or #f if
no update is needed or known."
none of UPDATERS matches PACKAGE. It is the caller's responsibility to ensure
that the returned source is newer than the current one."
(match (lookup-updater package updaters)
((? procedure? latest-release)
(match (latest-release package)
((and source ($ <upstream-source> name version))
(and (version>? version (package-version package))
source))
(_ #f)))
(#f #f)))
(latest-release package))
(_ #f)))
(define (package-latest-release* package updaters)
"Like 'package-latest-release', but ensure that the return source is newer
than that of PACKAGE."
(match (package-latest-release package updaters)
((and source ($ <upstream-source> name version))
(and (version>? version (package-version package))
source))
(_
#f)))
(define* (download-tarball store url signature-url
#:key (key-download 'interactive))
@ -179,7 +189,7 @@ values: the item from LST1 and the item from LST2 that match PRED."
PACKAGE, or #f and #f when PACKAGE is up-to-date. KEY-DOWNLOAD specifies a
download policy for missing OpenPGP keys; allowed values: 'always', 'never',
and 'interactive' (default)."
(match (package-update-path package updaters)
(match (package-latest-release* package updaters)
(($ <upstream-source> _ version urls signature-urls)
(let*-values (((name)
(package-name package))

18
m4/guix.m4
View File

@ -171,6 +171,24 @@ AC_DEFUN([GUIX_CHECK_UNBUFFERED_CBIP], [
fi])
])
dnl GUIX_CHECK_GUILE_SSH
dnl
dnl Check whether a recent-enough Guile-SSH is available.
AC_DEFUN([GUIX_CHECK_GUILE_SSH], [
dnl Check whether 'channel-send-eof' (introduced in 0.10.2) is present.
AC_CACHE_CHECK([whether Guile-SSH is available and recent enough],
[guix_cv_have_recent_guile_ssh],
[GUILE_CHECK([retval],
[(and (@ (ssh channel) channel-send-eof)
(@ (ssh popen) open-remote-pipe)
(@ (ssh dist node) node-eval))])
if test "$retval" = 0; then
guix_cv_have_recent_guile_ssh="yes"
else
guix_cv_have_recent_guile_ssh="no"
fi])
])
dnl GUIX_TEST_ROOT_DIRECTORY
AC_DEFUN([GUIX_TEST_ROOT_DIRECTORY], [
AC_CACHE_CHECK([for unit test root directory],