summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLeo Famulari <leo@famulari.name>2016-11-26 16:21:47 -0500
committerLeo Famulari <leo@famulari.name>2016-11-26 16:21:47 -0500
commita282cdae107c8aec512b563f25dd411183ef2830 (patch)
tree3359e7101ba120cb6d2dbd156327edd727bcc01a
parent3ad8cb4163deee77882ee4bded83a548752b896f (diff)
parentcd65d600ac6e8701ef9c54f5d09a45cd6c149949 (diff)
downloadguix-patches-a282cdae107c8aec512b563f25dd411183ef2830.tar
guix-patches-a282cdae107c8aec512b563f25dd411183ef2830.tar.gz
Merge branch 'master' into core-updates
-rw-r--r--.gitignore2
-rw-r--r--.mailmap9
-rw-r--r--build-aux/build-self.scm12
-rw-r--r--config-daemon.ac18
-rw-r--r--doc/guix.texi212
-rw-r--r--etc/guix-publish.conf.in12
-rw-r--r--etc/guix-publish.service.in19
-rw-r--r--gnu/build/install.scm5
-rw-r--r--gnu/build/marionette.scm87
-rw-r--r--gnu/local.mk7
-rw-r--r--gnu/packages/aspell.scm10
-rw-r--r--gnu/packages/audio.scm24
-rw-r--r--gnu/packages/bioinformatics.scm56
-rw-r--r--gnu/packages/bittorrent.scm5
-rw-r--r--gnu/packages/chez.scm11
-rw-r--r--gnu/packages/compression.scm10
-rw-r--r--gnu/packages/cups.scm4
-rw-r--r--gnu/packages/cyrus-sasl.scm9
-rw-r--r--gnu/packages/engineering.scm154
-rw-r--r--gnu/packages/gstreamer.scm5
-rw-r--r--gnu/packages/imagemagick.scm4
-rw-r--r--gnu/packages/ldc.scm20
-rw-r--r--gnu/packages/linux.scm4
-rw-r--r--gnu/packages/maths.scm5
-rw-r--r--gnu/packages/messaging.scm196
-rw-r--r--gnu/packages/music.scm8
-rw-r--r--gnu/packages/patches/cyrus-sasl-CVE-2013-4122.patch130
-rw-r--r--gnu/packages/patches/gst-plugins-good-fix-crashes.patch1047
-rw-r--r--gnu/packages/patches/gst-plugins-good-fix-invalid-read.patch37
-rw-r--r--gnu/packages/patches/gst-plugins-good-fix-signedness.patch58
-rw-r--r--gnu/packages/patches/gst-plugins-good-flic-bounds-check.patch319
-rw-r--r--gnu/packages/patches/ldc-disable-tests.patch50
-rw-r--r--gnu/packages/perl.scm31
-rw-r--r--gnu/packages/psyc.scm227
-rw-r--r--gnu/packages/python.scm44
-rw-r--r--gnu/packages/qemu.scm2
-rw-r--r--gnu/packages/ssh.scm17
-rw-r--r--gnu/packages/telephony.scm112
-rw-r--r--gnu/packages/upnp.scm27
-rw-r--r--gnu/packages/video.scm4
-rw-r--r--gnu/packages/vim.scm4
-rw-r--r--gnu/packages/web.scm5
-rw-r--r--gnu/packages/wxwidgets.scm81
-rw-r--r--gnu/services/configuration.scm205
-rw-r--r--gnu/services/cups.scm180
-rw-r--r--gnu/services/dbus.scm94
-rw-r--r--gnu/services/desktop.scm93
-rw-r--r--gnu/services/kerberos.scm10
-rw-r--r--gnu/services/mail.scm265
-rw-r--r--gnu/services/networking.scm3
-rw-r--r--gnu/system/examples/desktop.tmpl15
-rw-r--r--gnu/system/mapped-devices.scm8
-rw-r--r--gnu/tests/base.scm39
-rw-r--r--gnu/tests/install.scm66
-rw-r--r--guix/scripts/offload.scm584
-rw-r--r--guix/store.scm58
-rw-r--r--m4/guix.m418
-rw-r--r--nix/local.mk16
58 files changed, 3516 insertions, 1241 deletions
diff --git a/.gitignore b/.gitignore
index 329d489713..b64f5ef4b0 100644
--- a/.gitignore
+++ b/.gitignore
@@ -50,6 +50,8 @@
/emacs/guix-helper.scm
/etc/guix-daemon.conf
/etc/guix-daemon.service
+/etc/guix-publish.conf
+/etc/guix-publish.service
/guix-daemon
/guix-register
/guix/config.scm
diff --git a/.mailmap b/.mailmap
index 85f502161b..ada5026ba3 100644
--- a/.mailmap
+++ b/.mailmap
@@ -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>
diff --git a/build-aux/build-self.scm b/build-aux/build-self.scm
index 59028305e7..485f91b4c0 100644
--- a/build-aux/build-self.scm
+++ b/build-aux/build-self.scm
@@ -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,14 @@ 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)))
(build-guix #$output #$source
diff --git a/config-daemon.ac b/config-daemon.ac
index 8a3e6d8b60..056c939e39 100644
--- a/config-daemon.ac
+++ b/config-daemon.ac
@@ -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
diff --git a/doc/guix.texi b/doc/guix.texi
index 7381c2c6ba..5747484b20 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -453,7 +453,7 @@ If your host distro uses the systemd init system, this can be achieved
with these commands:
@example
-# cp ~root/.guix-profile/lib/systemd/system/guix-daemon.service \
+# ln -s ~root/.guix-profile/lib/systemd/system/guix-daemon.service \
/etc/systemd/system/
# systemctl start guix-daemon && systemctl enable guix-daemon
@end example
@@ -461,7 +461,7 @@ with these commands:
If your host distro uses the Upstart init system:
@example
-# cp ~root/.guix-profile/lib/upstart/system/guix-daemon.conf /etc/init/
+# ln -s ~root/.guix-profile/lib/upstart/system/guix-daemon.conf /etc/init/
# start guix-daemon
@end example
@@ -567,6 +567,12 @@ 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}).
@end itemize
@@ -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
@@ -6055,6 +6088,30 @@ add a call to @code{guix-publish-service} in the @code{services} field
of the @code{operating-system} declaration (@pxref{guix-publish-service,
@code{guix-publish-service}}).
+If you are instead running Guix on a ``foreign distro'', follow these
+instructions:”
+
+@itemize
+@item
+If your host distro uses the systemd init system:
+
+@example
+# ln -s ~root/.guix-profile/lib/systemd/system/guix-publish.service \
+ /etc/systemd/system/
+# systemctl start guix-publish && systemctl enable guix-publish
+@end example
+
+@item
+If your host distro uses the Upstart init system:
+
+@example
+# ln -s ~root/.guix-profile/lib/upstart/system/guix-publish.conf /etc/init/
+# start guix-publish
+@end example
+
+@item
+Otherwise, proceed similarly with your distro's init system.
+@end itemize
@node Invoking guix challenge
@section Invoking @command{guix challenge}
@@ -6641,27 +6698,26 @@ partition lives at @file{/dev/sda1}, a file system with the label
mkfs.ext4 -L my-root /dev/sda1
@end example
-@c FIXME: Uncomment this once GRUB fully supports encrypted roots.
-@c A typical command sequence may be:
-@c
-@c @example
-@c # fdisk /dev/sdX
-@c @dots{} Create partitions etc.@dots{}
-@c # cryptsetup luksFormat /dev/sdX1
-@c # cryptsetup open --type luks /dev/sdX1 my-partition
-@c # mkfs.ext4 -L my-root /dev/mapper/my-partition
-@c @end example
+@cindex encrypted disk
+If you are instead planning to encrypt the root partition, you can use
+the Cryptsetup/LUKS utilities to do that (see @inlinefmtifelse{html,
+@uref{https://linux.die.net/man/8/cryptsetup, @code{man cryptsetup}},
+@code{man cryptsetup}} for more information.) Assuming you want to
+store the root partition on @file{/dev/sda1}, the command sequence would
+be along these lines:
-In addition to e2fsprogs, the suite of tools to manipulate
-ext2/ext3/ext4 file systems, the installation image includes
-Cryptsetup/LUKS for disk encryption.
+@example
+cryptsetup luksFormat /dev/sda1
+cryptsetup open --type luks /dev/sda1 my-partition
+mkfs.ext4 -L my-root /dev/mapper/my-partition
+@end example
Once that is done, mount the target root partition under @file{/mnt}
-with a command like (again, assuming @file{/dev/sda1} is the root
-partition):
+with a command like (again, assuming @code{my-root} is the label of the
+root partition):
@example
-mount /dev/sda1 /mnt
+mount LABEL=my-root /mnt
@end example
Finally, if you plan to use one or more swap partitions (@pxref{Memory
@@ -6724,6 +6780,10 @@ Be sure that your partition labels match the value of their respective
@code{device} fields in your @code{file-system} configuration, assuming
your @code{file-system} configuration sets the value of @code{title} to
@code{'label}.
+
+@item
+If there are encrypted or RAID partitions, make sure to add a
+@code{mapped-devices} field to describe them (@pxref{Mapped Devices}).
@end itemize
Once you are done preparing the configuration file, the new system must
@@ -6968,7 +7028,9 @@ desired configuration. In particular, notice how we use @code{inherit}
to create a new configuration which has the same values as the old
configuration, but with a few modifications.
-The configuration for a typical ``desktop'' usage, with the X11 display
+@cindex encrypted disk
+The configuration for a typical ``desktop'' usage, with an encrypted
+root partition, the X11 display
server, GNOME and Xfce (users can choose which of these desktop
environments to use at the log-in screen by pressing @kbd{F1}), network
management, power management, and more, would look like this:
@@ -7293,13 +7355,16 @@ errors before being mounted.
When true, the mount point is created if it does not exist yet.
@item @code{dependencies} (default: @code{'()})
-This is a list of @code{<file-system>} objects representing file systems
-that must be mounted before (and unmounted after) this one.
+This is a list of @code{<file-system>} or @code{<mapped-device>} objects
+representing file systems that must be mounted or mapped devices that
+must be opened before (and unmounted or closed after) this one.
As an example, consider a hierarchy of mounts: @file{/sys/fs/cgroup} is
a dependency of @file{/sys/fs/cgroup/cpu} and
@file{/sys/fs/cgroup/memory}.
+Another example is a file system that depends on a mapped device, for
+example for an encrypted partition (@pxref{Mapped Devices}).
@end table
@end deftp
@@ -8407,13 +8472,22 @@ configure networking."
@end deffn
@cindex WPA Supplicant
-@deffn {Scheme Procedure} wpa-supplicant-service @
- [#:wpa-supplicant @var{wpa-supplicant}]
-Return a service that runs @url{https://w1.fi/wpa_supplicant/,WPA
+@defvr {Scheme Variable} wpa-supplicant-service-type
+This is the service type to run @url{https://w1.fi/wpa_supplicant/,WPA
supplicant}, an authentication daemon required to authenticate against
-encrypted WiFi or ethernet networks. Service is started to listen for
+encrypted WiFi or ethernet networks. It is configured to listen for
requests on D-Bus.
-@end deffn
+
+The value of this service is the @code{wpa-supplicant} package to use.
+Thus, it can be instantiated like this:
+
+@lisp
+(use-modules (gnu services networking)
+ (gnu packages admin))
+
+(service wpa-supplicant-type wpa-supplicant)
+@end lisp
+@end defvr
@cindex NTP
@cindex real time clock
@@ -9979,7 +10053,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
@@ -10001,16 +10075,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.
@@ -11366,18 +11435,47 @@ 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
@cindex Kerberos
-The @code{(gnu services Kerberos)} module provides services relating to
+The @code{(gnu services kerberos)} module provides services relating to
the authentication protocol @dfn{Kerberos}.
@subsubheading PAM krb5 Service
@cindex pam-krb5
-The pam-krb5 service allows for login authentication and password
+The @code{pam-krb5} service allows for login authentication and password
management via Kerberos.
You will need this service if you want PAM enabled applications to authenticate
users using Kerberos.
diff --git a/etc/guix-publish.conf.in b/etc/guix-publish.conf.in
new file mode 100644
index 0000000000..498fa295be
--- /dev/null
+++ b/etc/guix-publish.conf.in
@@ -0,0 +1,12 @@
+# This is a "job" for the Upstart init system to launch 'guix-daemon'.
+# Drop it in /etc/init to have 'guix-daemon' automatically started.
+
+description "Publish the GNU Guix store"
+
+start on runlevel [2345]
+
+stop on runlevel [016]
+
+task
+
+exec @bindir@/guix publish --user=nobody --port=8181
diff --git a/etc/guix-publish.service.in b/etc/guix-publish.service.in
new file mode 100644
index 0000000000..fc4e3c21f3
--- /dev/null
+++ b/etc/guix-publish.service.in
@@ -0,0 +1,19 @@
+# This is a "service unit file" for the systemd init system to launch
+# 'guix publish'. Drop it in /etc/systemd/system or similar to have
+# 'guix publish' automatically started.
+
+[Unit]
+Description=Publish the GNU Guix store
+
+[Service]
+ExecStart=@bindir@/guix publish --user=nobody --port=8181
+Environment=GUIX_LOCPATH=/root/.guix-profile/lib/locale
+RemainAfterExit=yes
+StandardOutput=syslog
+StandardError=syslog
+
+# See <https://lists.gnu.org/archive/html/guix-devel/2016-04/msg00608.html>.
+TasksMax=1024
+
+[Install]
+WantedBy=multi-user.target
diff --git a/gnu/build/install.scm b/gnu/build/install.scm
index 3d1594e203..5c2b35632d 100644
--- a/gnu/build/install.scm
+++ b/gnu/build/install.scm
@@ -46,6 +46,11 @@ Note that the caller must make sure that GRUB.CFG is registered as a GC root
so that the fonts, background images, etc. referred to by GRUB.CFG are not
GC'd."
(install-grub-config grub.cfg mount-point)
+
+ ;; Tell 'grub-install' that there might be a LUKS-encrypted /boot or root
+ ;; partition.
+ (setenv "GRUB_ENABLE_CRYPTODISK" "y")
+
(unless (zero? (system* "grub-install" "--no-floppy"
"--boot-directory"
(string-append mount-point "/boot")
diff --git a/gnu/build/marionette.scm b/gnu/build/marionette.scm
index d36e1c8d09..506d6da420 100644
--- a/gnu/build/marionette.scm
+++ b/gnu/build/marionette.scm
@@ -21,10 +21,13 @@
#:use-module (srfi srfi-26)
#:use-module (rnrs io ports)
#:use-module (ice-9 match)
+ #:use-module (ice-9 popen)
#:export (marionette?
make-marionette
marionette-eval
marionette-control
+ marionette-screen-text
+ wait-for-screen-text
%qwerty-us-keystrokes
marionette-type))
@@ -45,7 +48,10 @@
(command marionette-command) ;list of strings
(pid marionette-pid) ;integer
(monitor marionette-monitor) ;port
- (repl marionette-repl)) ;port
+ (repl %marionette-repl)) ;promise of a port
+
+(define-syntax-rule (marionette-repl marionette)
+ (force (%marionette-repl marionette)))
(define* (wait-for-monitor-prompt port #:key (quiet? #t))
"Read from PORT until we have seen all of QEMU's monitor prompt. When
@@ -131,21 +137,29 @@ QEMU monitor and to the guest's backdoor REPL."
(close-port monitor)
(wait-for-monitor-prompt monitor-conn)
(display "read QEMU monitor prompt\n")
- (match (accept* repl)
- ((repl-conn . addr)
- (display "connected to guest REPL\n")
- (close-port repl)
- (match (read repl-conn)
- ('ready
- (alarm 0)
- (display "marionette is ready\n")
- (marionette (append command extra-options) pid
- monitor-conn repl-conn)))))))))))
+
+ (marionette (append command extra-options) pid
+ monitor-conn
+
+ ;; The following 'accept' call connects immediately, but
+ ;; we don't know whether the guest has connected until
+ ;; we actually receive the 'ready' message.
+ (match (accept* repl)
+ ((repl-conn . addr)
+ (display "connected to guest REPL\n")
+ (close-port repl)
+ ;; Delay reception of the 'ready' message so that the
+ ;; caller can already send monitor commands.
+ (delay
+ (match (read repl-conn)
+ ('ready
+ (display "marionette is ready\n")
+ repl-conn))))))))))))
(define (marionette-eval exp marionette)
"Evaluate EXP in MARIONETTE's backdoor REPL. Return the result."
(match marionette
- (($ <marionette> command pid monitor repl)
+ (($ <marionette> command pid monitor (= force repl))
(write exp repl)
(newline repl)
(read repl))))
@@ -160,6 +174,55 @@ pcsys_monitor\")."
(newline monitor)
(wait-for-monitor-prompt monitor))))
+(define* (marionette-screen-text marionette
+ #:key
+ (ocrad "ocrad"))
+ "Take a screenshot of MARIONETTE, perform optical character
+recognition (OCR), and return the text read from the screen as a string. Do
+this by invoking OCRAD (file name for GNU Ocrad's command)"
+ (define (random-file-name)
+ (string-append "/tmp/marionette-screenshot-"
+ (number->string (random (expt 2 32)) 16)
+ ".ppm"))
+
+ (let ((image (random-file-name)))
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (marionette-control (string-append "screendump " image)
+ marionette)
+
+ ;; Tell Ocrad to invert the image colors (make it black on white) and
+ ;; to scale the image up, which significantly improves the quality of
+ ;; the result. In spite of this, be aware that OCR confuses "y" and
+ ;; "V" and sometimes erroneously introduces white space.
+ (let* ((pipe (open-pipe* OPEN_READ ocrad
+ "-i" "-s" "10" image))
+ (text (get-string-all pipe)))
+ (unless (zero? (close-pipe pipe))
+ (error "'ocrad' failed" ocrad))
+ text))
+ (lambda ()
+ (false-if-exception (delete-file image))))))
+
+(define* (wait-for-screen-text marionette predicate
+ #:key (timeout 30) (ocrad "ocrad"))
+ "Wait for TIMEOUT seconds or until the screen text on MARIONETTE matches
+PREDICATE, whichever comes first. Raise an error when TIMEOUT is exceeded."
+ (define start
+ (car (gettimeofday)))
+
+ (define end
+ (+ start timeout))
+
+ (let loop ()
+ (if (> (car (gettimeofday)) end)
+ (error "'wait-for-screen-text' timeout" predicate)
+ (or (predicate (marionette-screen-text marionette #:ocrad ocrad))
+ (begin
+ (sleep 1)
+ (loop))))))
+
(define %qwerty-us-keystrokes
;; Maps "special" characters to their keystrokes.
'((#\newline . "ret")
diff --git a/gnu/local.mk b/gnu/local.mk
index 52e0742301..ea5100141b 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -305,7 +305,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 +399,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 \
@@ -506,6 +506,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 \
@@ -585,6 +586,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 \
diff --git a/gnu/packages/aspell.scm b/gnu/packages/aspell.scm
index b7024124bd..b3ca380533 100644
--- a/gnu/packages/aspell.scm
+++ b/gnu/packages/aspell.scm
@@ -1,7 +1,8 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
-;;; Copyright ©2016 John Darrington <jmd@gnu.org>
+;;; Copyright © 2016 John Darrington <jmd@gnu.org>
+;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -155,3 +156,10 @@ dictionaries, including personal ones.")
#:sha256
(base32
"0ffb87yjsh211hllpc4b9khqqrblial4pzi1h9r3v465z1yhn3j4")))
+
+(define-public aspell-dict-he
+ (aspell-dictionary "he" "Hebrew"
+ #:version "1.0-0"
+ #:sha256
+ (base32
+ "13bhbghx5b8g0119g3wxd4n8mlf707y41vlf59irxjj0kynankfn")))
diff --git a/gnu/packages/audio.scm b/gnu/packages/audio.scm
index 492f716ca9..b535448af1 100644
--- a/gnu/packages/audio.scm
+++ b/gnu/packages/audio.scm
@@ -8,6 +8,7 @@
;;; Copyright © 2016 Alex Griffin <a@ajgrf.com>
;;; Copyright © 2016 ng0 <ng0@we.make.ritual.n0.is>
;;; Copyright © 2016 Lukas Gradl <lgradl@openmailbox.org>
+;;; Copyright © 2016 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -1177,19 +1178,24 @@ well suited to all musical instruments and vocals.")
(version "1.3.2")
(source (origin
(method url-fetch)
- (uri (string-append
- "http://factorial.hu/system/files/ir.lv2-"
- version ".tar.gz"))
+ ;; The original home-page is gone. Download the tarball from an
+ ;; archive mirror instead.
+ (uri (list (string-append
+ "https://web.archive.org/web/20150803095032/"
+ "http://factorial.hu/system/files/ir.lv2-"
+ version ".tar.gz")
+ (string-append
+ "https://mirrors.kernel.org/gentoo/distfiles/ir.lv2-"
+ version ".tar.gz")))
(sha256
(base32
"1jh2z01l9m4ar7yz0n911df07dygc7n4cl59p7qdjbh0nvkm747g"))))
(build-system gnu-build-system)
(arguments
- `(#:tests? #f ;no "check" target
+ `(#:tests? #f ; no tests
#:make-flags (list (string-append "PREFIX=" (assoc-ref %outputs "out")))
- #:phases
- ;; no configure script
- (alist-delete 'configure %standard-phases)))
+ #:phases (modify-phases %standard-phases
+ (delete 'configure)))) ; no configure script
(inputs
`(("libsndfile" ,libsndfile)
("libsamplerate" ,libsamplerate)
@@ -1203,7 +1209,9 @@ well suited to all musical instruments and vocals.")
(list (search-path-specification
(variable "LV2_PATH")
(files '("lib/lv2")))))
- (home-page "http://factorial.hu/plugins/lv2/ir")
+ ;; Link to an archived copy of the home-page since the original is gone.
+ (home-page (string-append "https://web.archive.org/web/20150803095032/"
+ "http://factorial.hu/plugins/lv2/ir"))
(synopsis "LV2 convolution reverb")
(description
"IR is a low-latency, real-time, high performance signal convolver
diff --git a/gnu/packages/bioinformatics.scm b/gnu/packages/bioinformatics.scm
index 773b5909b6..8d2cb93c7c 100644
--- a/gnu/packages/bioinformatics.scm
+++ b/gnu/packages/bioinformatics.scm
@@ -3693,6 +3693,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")
@@ -3765,7 +3817,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)
@@ -3774,7 +3826,7 @@ partial genes, and identifies translation initiation sites.")
version ".tar.gz"))
(sha256
(base32
- "0g0pzcv8y7n2w8q7c9q0a7s2ghkwci6w8smg9mjw4agad5cd7yaw"))))
+ "0x2hpb3nfsc6x2nq1788w0fhqfzc7cn2dp4xwyva9m3k6xlz0m43"))))
(build-system perl-build-system)
(arguments
`(#:phases
diff --git a/gnu/packages/bittorrent.scm b/gnu/packages/bittorrent.scm
index ad67e02270..eff1b5a1c4 100644
--- a/gnu/packages/bittorrent.scm
+++ b/gnu/packages/bittorrent.scm
@@ -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)
diff --git a/gnu/packages/chez.scm b/gnu/packages/chez.scm
index 5edce56505..6b2b70f19e 100644
--- a/gnu/packages/chez.scm
+++ b/gnu/packages/chez.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Federico Beffa <beffa@fbengineering.ch>
+;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -34,7 +35,8 @@
#:use-module (gnu packages compression)
#:use-module (gnu packages image)
#:use-module (gnu packages xorg)
- #:use-module (ice-9 match))
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1))
(define nanopass
(let ((version "1.9"))
@@ -94,8 +96,7 @@
(list ,(match (or (%current-target-system) (%current-system))
("x86_64-linux" '(list "--machine=ta6le"))
("i686-linux" '(list "--machine=ti3le"))
- ;; FIXME: Some people succeeded in cross-compiling to
- ;; ARM. https://github.com/cisco/ChezScheme/issues/13
+ ;; Let autodetection have its attempt on other architectures.
(_
'())))
#:phases
@@ -191,7 +192,9 @@
(find-files lib "scheme.boot"))
#t))))))
;; According to the documentation MIPS is not supported.
- (supported-systems (delete "mips64el-linux" %supported-systems))
+ ;; Cross-compiling for the Raspberry Pi is supported, but not native ARM.
+ (supported-systems (fold delete %supported-systems
+ '("mips64el-linux" "armhf-linux")))
(home-page "http://www.scheme.com")
(synopsis "R6RS Scheme compiler and run-time")
(description
diff --git a/gnu/packages/compression.scm b/gnu/packages/compression.scm
index b6c8604a23..bdf87562e4 100644
--- a/gnu/packages/compression.scm
+++ b/gnu/packages/compression.scm
@@ -603,24 +603,24 @@ writing of compressed data created with the zlib and bzip2 libraries.")
(define-public lz4
(package
(name "lz4")
- (version "131")
+ (version "1.7.4.2")
(source
(origin
(method url-fetch)
(uri (string-append "https://github.com/Cyan4973/lz4/archive/"
- "r" version ".tar.gz"))
+ "v" version ".tar.gz"))
(sha256
- (base32 "1vfg305zvj50hwscad24wan9jar6nqj14gdk2hqyr7bb9mhh0kcx"))
+ (base32 "0l39bymif15rmmfz7h6wvrr853rix4wj8wbqq8z8fm49xa7gx9fb"))
(file-name (string-append name "-" version ".tar.gz"))))
(build-system gnu-build-system)
- (native-inputs `(("valgrind" ,valgrind)))
+ (native-inputs `(("valgrind" ,valgrind))) ; for tests
(arguments
`(#:test-target "test"
#:parallel-tests? #f ; tests fail if run in parallel
#:make-flags (list "CC=gcc"
(string-append "PREFIX=" (assoc-ref %outputs "out")))
#:phases (modify-phases %standard-phases
- (delete 'configure))))
+ (delete 'configure)))) ; no configure script
(home-page "https://github.com/Cyan4973/lz4")
(synopsis "Compression algorithm focused on speed")
(description "LZ4 is a lossless compression algorithm, providing
diff --git a/gnu/packages/cups.scm b/gnu/packages/cups.scm
index 802accf6c6..0a8a10ecb4 100644
--- a/gnu/packages/cups.scm
+++ b/gnu/packages/cups.scm
@@ -317,14 +317,14 @@ device-specific programs to convert and print many types of files.")
(define-public hplip
(package
(name "hplip")
- (version "3.16.10")
+ (version "3.16.11")
(source (origin
(method url-fetch)
(uri (string-append "mirror://sourceforge/hplip/hplip/" version
"/hplip-" version ".tar.gz"))
(sha256
(base32
- "117f1p0splg51ljn4nn97c0mbl0jba440ahb3d8njq7p6h1lxd25"))))
+ "094vkyr0rjng72m13dgr824cdl7q20x23qjxzih4w7l9njn0rqpn"))))
(build-system gnu-build-system)
(home-page "http://hplipopensource.com/")
(synopsis "HP Printer Drivers")
diff --git a/gnu/packages/cyrus-sasl.scm b/gnu/packages/cyrus-sasl.scm
index 99ff1e228e..89a4a49797 100644
--- a/gnu/packages/cyrus-sasl.scm
+++ b/gnu/packages/cyrus-sasl.scm
@@ -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"))))))
diff --git a/gnu/packages/engineering.scm b/gnu/packages/engineering.scm
index f720906534..831e63beda 100644
--- a/gnu/packages/engineering.scm
+++ b/gnu/packages/engineering.scm
@@ -4,6 +4,7 @@
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2016 David Thompson <davet@gnu.org>
;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016 Theodoros Foradis <theodoros.for@openmailbox.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -29,6 +30,7 @@
#:use-module (guix store)
#:use-module (guix utils)
#:use-module ((guix licenses) #:prefix license:)
+ #:use-module (guix build-system cmake)
#:use-module (guix build-system gnu)
#:use-module (guix build-system cmake)
#:use-module (gnu packages)
@@ -39,6 +41,7 @@
#:use-module (gnu packages boost)
#:use-module (gnu packages check)
#:use-module (gnu packages compression)
+ #:use-module (gnu packages curl)
#:use-module (gnu packages flex)
#:use-module (gnu packages fontutils)
#:use-module (gnu packages gd)
@@ -55,9 +58,14 @@
#:use-module (gnu packages maths)
#:use-module (gnu packages perl)
#:use-module (gnu packages pkg-config)
+ #:use-module (gnu packages python)
#:use-module (gnu packages qt)
+ #:use-module (gnu packages swig)
#:use-module (gnu packages tcl)
+ #:use-module (gnu packages tls)
#:use-module (gnu packages tex)
+ #:use-module (gnu packages wxwidgets)
+ #:use-module (gnu packages xorg)
#:use-module (srfi srfi-1))
(define-public librecad
@@ -588,3 +596,149 @@ fundamental, primitive shapes are represented as code in the user-level
language.")
(license (list license:lgpl2.1+ ;library
license:gpl2+))))) ;Guile bindings
+
+;; We use kicad from a git commit, because support for boost 1.61.0 has been
+;; recently added.
+(define-public kicad
+ (let ((commit "4ee344e150bfaf3a6f3f7bf935fb96ae07c423fa")
+ (revision "1"))
+ (package
+ (name "kicad")
+ (version (string-append "4.0-" revision "."
+ (string-take commit 7)))
+ (source
+ (origin
+ (method git-fetch)
+ (uri (git-reference
+ (url "https://git.launchpad.net/kicad")
+ (commit commit)))
+ (sha256
+ (base32 "0kf6r92nps0658i9n3p9vp5dzbssmc22lvjv5flyvnlf83l63s4n"))
+ (file-name (string-append name "-" version "-checkout"))))
+ (build-system cmake-build-system)
+ (arguments
+ `(#:out-of-source? #t
+ #:tests? #f ; no tests
+ #:configure-flags
+ (list "-DKICAD_STABLE_VERSION=ON"
+ "-DKICAD_REPO_NAME=stable"
+ ,(string-append "-DKICAD_BUILD_VERSION=4.0-"
+ (string-take commit 7))
+ "-DCMAKE_BUILD_TYPE=Release"
+ "-DKICAD_SKIP_BOOST=ON"; Use our system's boost library.
+ "-DKICAD_SCRIPTING=ON"
+ "-DKICAD_SCRIPTING_MODULES=ON"
+ "-DKICAD_SCRIPTING_WXPYTHON=ON"
+ ;; Has to be set explicitely, as we don't have the wxPython
+ ;; headers in the wxwidgets store item, but in wxPython.
+ (string-append "-DCMAKE_CXX_FLAGS=-I"
+ (assoc-ref %build-inputs "wxpython")
+ "/include/wx-3.0")
+ "-DCMAKE_BUILD_WITH_INSTALL_RPATH=TRUE"
+ ;; TODO: Enable this when CA certs are working with curl.
+ "-DBUILD_GITHUB_PLUGIN=OFF")
+ #:phases
+ (modify-phases %standard-phases
+ (add-after 'install 'wrap-program
+ ;; Ensure correct Python at runtime.
+ (lambda* (#:key inputs outputs #:allow-other-keys)
+ (let* ((out (assoc-ref outputs "out"))
+ (python (assoc-ref inputs "python"))
+ (file (string-append out "/bin/kicad"))
+ (path (string-append
+ out
+ "/lib/python2.7/site-packages:"
+ (getenv "PYTHONPATH"))))
+ (wrap-program file
+ `("PYTHONPATH" ":" prefix (,path))
+ `("PATH" ":" prefix
+ (,(string-append python "/bin:")))))
+ #t)))))
+ (native-inputs
+ `(("boost" ,boost)
+ ("gettext" ,gnu-gettext)
+ ("pkg-config" ,pkg-config)
+ ("swig" ,swig)
+ ("zlib" ,zlib)))
+ (inputs
+ `(("cairo" ,cairo)
+ ("curl" ,curl)
+ ("desktop-file-utils" ,desktop-file-utils)
+ ("glew" ,glew)
+ ("glm" ,glm)
+ ("hicolor-icon-theme" ,hicolor-icon-theme)
+ ("libsm" ,libsm)
+ ("mesa" ,mesa)
+ ("openssl" ,openssl)
+ ("python" ,python-2)
+ ("wxwidgets" ,wxwidgets-gtk2)
+ ("wxpython" ,python2-wxpython)))
+ (home-page "http://kicad-pcb.org/")
+ (synopsis "Electronics Design Automation Suite")
+ (description "Kicad is a program for the formation of printed circuit
+boards and electrical circuits. The software has a number of programs that
+perform specific functions, for example, pcbnew (Editing PCB), eeschema (editing
+electrical diagrams), gerbview (viewing Gerber files) and others.")
+ (license license:gpl3+))))
+
+(define-public kicad-library
+ (let ((version "4.0.4"))
+ (package
+ (name "kicad-library")
+ (version version)
+ (source (origin
+ (method url-fetch)
+ (uri (string-append
+ "http://downloads.kicad-pcb.org/libraries/kicad-library-"
+ version ".tar.gz"))
+ (sha256
+ (base32
+ "1wyda58y39lhxml0xv1ngvddi0nqihx9bnlza46ajzms38ajvh12"))))
+ (build-system cmake-build-system)
+ (arguments
+ `(#:out-of-source? #t
+ #:tests? #f ; no tests
+ #:phases
+ (modify-phases %standard-phases
+ (add-after 'install 'install-footprints ; from footprints tarball
+ (lambda* (#:key inputs outputs #:allow-other-keys)
+ (zero? (system* "tar" "xvf"
+ (assoc-ref inputs "kicad-footprints")
+ "-C" (string-append (assoc-ref outputs "out")
+ "/share/kicad/modules")
+ "--strip-components=1"))))
+ ;; We change the default global footprint file, which is generated if
+ ;; it doesn't exist in user's home directory, from the one using the
+ ;; github plugin, to the one using the KISYSMOD environment path.
+ (add-after 'install-footprints 'use-pretty-footprint-table
+ (lambda* (#:key outputs #:allow-other-keys)
+ (let* ((out (assoc-ref outputs "out"))
+ (template-dir (string-append out "/share/kicad/template"))
+ (fp-lib-table (string-append template-dir "/fp-lib-table")))
+ (delete-file fp-lib-table)
+ (copy-file (string-append fp-lib-table ".for-pretty")
+ fp-lib-table))
+ #t)))))
+ (native-search-paths
+ (list (search-path-specification
+ (variable "KISYSMOD") ; footprint path
+ (files '("share/kicad/modules")))
+ (search-path-specification
+ (variable "KISYS3DMOD") ; 3D model path
+ (files '("share/kicad/modules/packages3d")))))
+ ;; Kicad distributes footprints in a separate tarball
+ (native-inputs
+ `(("kicad-footprints"
+ ,(origin
+ (method url-fetch)
+ (uri (string-append
+ "http://downloads.kicad-pcb.org/libraries/kicad-footprints-"
+ version ".tar.gz"))
+ (sha256
+ (base32
+ "0ya4gg6clz3vp2wrb67xwg0bhwh5q8ag39jjmpcp4zjcqs1f48rb"))))))
+ (home-page "http://kicad-pcb.org/")
+ (synopsis "Libraries for kicad")
+ (description "This package provides Kicad component, footprint and 3D
+render model libraries.")
+ (license license:lgpl2.0+))))
diff --git a/gnu/packages/gstreamer.scm b/gnu/packages/gstreamer.scm
index 5fe84ec2fc..86ea690e8b 100644
--- a/gnu/packages/gstreamer.scm
+++ b/gnu/packages/gstreamer.scm
@@ -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"))))
diff --git a/gnu/packages/imagemagick.scm b/gnu/packages/imagemagick.scm
index 99d8b76299..4e70212133 100644
--- a/gnu/packages/imagemagick.scm
+++ b/gnu/packages/imagemagick.scm
@@ -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")
diff --git a/gnu/packages/ldc.scm b/gnu/packages/ldc.scm
index 560fa497fb..6ea7f664bd 100644
--- a/gnu/packages/ldc.scm
+++ b/gnu/packages/ldc.scm
@@ -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
diff --git a/gnu/packages/linux.scm b/gnu/packages/linux.scm
index 308be10dbd..c504a1260b 100644
--- a/gnu/packages/linux.scm
+++ b/gnu/packages/linux.scm
@@ -2664,7 +2664,7 @@ and copy/paste text in the console and in xterm.")
(define-public btrfs-progs
(package
(name "btrfs-progs")
- (version "4.8.3")
+ (version "4.8.4")
(source (origin
(method url-fetch)
(uri (string-append "mirror://kernel.org/linux/kernel/"
@@ -2672,7 +2672,7 @@ and copy/paste text in the console and in xterm.")
"btrfs-progs-v" version ".tar.xz"))
(sha256
(base32
- "1wlflrygnpndppil9g12pk184f75g9qx1lkr0x1gijigglqhr9n1"))))
+ "1ib1ybpjhcymcycjiraz1vk01qlyvpwcg7mwfhmacdy3cvbfl9mz"))))
(build-system gnu-build-system)
(outputs '("out"
"static")) ; static versions of binaries in "out" (~16MiB!)
diff --git a/gnu/packages/maths.scm b/gnu/packages/maths.scm
index 0c51f6d54f..e432ed5c05 100644
--- a/gnu/packages/maths.scm
+++ b/gnu/packages/maths.scm
@@ -563,7 +563,10 @@ incompatible with HDF5.")
(inputs
`(("zlib" ,zlib)))
(arguments
- `(#:phases
+ `(;; Some of the users, notably Flann, need the C++ interface.
+ #:configure-flags '("--enable-cxx")
+
+ #:phases
(modify-phases %standard-phases
(add-before 'configure 'patch-configure
(lambda _
diff --git a/gnu/packages/messaging.scm b/gnu/packages/messaging.scm
index 72b89067f0..8660915bb0 100644
--- a/gnu/packages/messaging.scm
+++ b/gnu/packages/messaging.scm
@@ -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
diff --git a/gnu/packages/music.scm b/gnu/packages/music.scm
index 64e7455603..78ca558b2d 100644
--- a/gnu/packages/music.scm
+++ b/gnu/packages/music.scm
@@ -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"))
@@ -1638,14 +1638,14 @@ computer's keyboard.")
(define-public qtractor
(package
(name "qtractor")
- (version "0.7.9")
+ (version "0.8.0")
(source (origin
(method url-fetch)
(uri (string-append "http://downloads.sourceforge.net/qtractor/"
"qtractor-" version ".tar.gz"))
(sha256
(base32
- "0pp459kfgrnngj373gnwwl43xjz32lmyf7v62p2nnjh6c7wr1ryq"))))
+ "17v563liyqcvil204ry1qfp09d91944nqz2ig33f5c3pyg4z2427"))))
(build-system gnu-build-system)
(arguments `(#:tests? #f)) ; no "check" target
(inputs
diff --git a/gnu/packages/patches/cyrus-sasl-CVE-2013-4122.patch b/gnu/packages/patches/cyrus-sasl-CVE-2013-4122.patch
new file mode 100644
index 0000000000..fc72e42e03
--- /dev/null
+++ b/gnu/packages/patches/cyrus-sasl-CVE-2013-4122.patch
@@ -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
+
diff --git a/gnu/packages/patches/gst-plugins-good-fix-crashes.patch b/gnu/packages/patches/gst-plugins-good-fix-crashes.patch
new file mode 100644
index 0000000000..c36a595608
--- /dev/null
+++ b/gnu/packages/patches/gst-plugins-good-fix-crashes.patch
@@ -0,0 +1,1047 @@
+Fixes upstream bug #774859 (flic decoder: Invalid memory read in
+flx_decode_chunks):
+
+https://bugzilla.gnome.org/show_bug.cgi?id=774859
+
+Patch copied from upstream source repository:
+
+https://cgit.freedesktop.org/gstreamer/gst-plugins-good/commit/?id=be670f0daf67304fb92c76aa09c30cae0bfd1fe4
+
+From be670f0daf67304fb92c76aa09c30cae0bfd1fe4 Mon Sep 17 00:00:00 2001
+From: Matthew Waters <matthew@centricular.com>
+Date: Wed, 23 Nov 2016 07:09:06 +1100
+Subject: [PATCH] flxdec: rewrite logic based on GstByteReader/Writer
+
+Solves overreading/writing the given arrays and will error out if the
+streams asks to do that.
+
+Also does more error checking that the stream is valid and won't
+overrun any allocated arrays. Also mitigate integer overflow errors
+calculating allocation sizes.
+
+https://bugzilla.gnome.org/show_bug.cgi?id=774859
+---
+ gst/flx/flx_color.c | 1 -
+ gst/flx/flx_fmt.h | 72 -------
+ gst/flx/gstflxdec.c | 610 ++++++++++++++++++++++++++++++++++++----------------
+ gst/flx/gstflxdec.h | 4 +-
+ 4 files changed, 427 insertions(+), 260 deletions(-)
+
+diff --git a/gst/flx/flx_color.c b/gst/flx/flx_color.c
+index 047bfdf..3a58135 100644
+--- a/gst/flx/flx_color.c
++++ b/gst/flx/flx_color.c
+@@ -101,7 +101,6 @@ flx_set_palette_vector (FlxColorSpaceConverter * flxpal, guint start, guint num,
+ } else {
+ memcpy (&flxpal->palvec[start * 3], newpal, grab * 3);
+ }
+-
+ }
+
+ void
+diff --git a/gst/flx/flx_fmt.h b/gst/flx/flx_fmt.h
+index 9ab31ba..abff200 100644
+--- a/gst/flx/flx_fmt.h
++++ b/gst/flx/flx_fmt.h
+@@ -123,78 +123,6 @@ typedef struct _FlxFrameType
+ } FlxFrameType;
+ #define FlxFrameTypeSize 10
+
+-#if G_BYTE_ORDER == G_BIG_ENDIAN
+-#define LE_TO_BE_16(i16) ((guint16) (((i16) << 8) | ((i16) >> 8)))
+-#define LE_TO_BE_32(i32) \
+- (((guint32) (LE_TO_BE_16((guint16) (i32))) << 16) | (LE_TO_BE_16((i32) >> 16)))
+-
+-#define FLX_FRAME_TYPE_FIX_ENDIANNESS(frm_type_p) \
+- do { \
+- (frm_type_p)->chunks = LE_TO_BE_16((frm_type_p)->chunks); \
+- (frm_type_p)->delay = LE_TO_BE_16((frm_type_p)->delay); \
+- } while(0)
+-
+-#define FLX_HUFFMAN_TABLE_FIX_ENDIANNESS(hffmn_table_p) \
+- do { \
+- (hffmn_table_p)->codelength = \
+- LE_TO_BE_16((hffmn_table_p)->codelength); \
+- (hffmn_table_p)->numcodes = LE_TO_BE_16((hffmn_table_p)->numcodes); \
+- } while(0)
+-
+-#define FLX_SEGMENT_TABLE_FIX_ENDIANNESS(sgmnt_table_p) \
+- ((sgmnt_table_p)->segments = LE_TO_BE_16((sgmnt_table_p)->segments))
+-
+-#define FLX_PREFIX_CHUNK_FIX_ENDIANNESS(prfx_chnk_p) \
+- do { \
+- (prfx_chnk_p)->chunks = LE_TO_BE_16((prfx_chnk_p)->chunks); \
+- } while(0)
+-
+-#define FLX_FRAME_CHUNK_FIX_ENDIANNESS(frm_chnk_p) \
+- do { \
+- (frm_chnk_p)->size = LE_TO_BE_32((frm_chnk_p)->size); \
+- (frm_chnk_p)->id = LE_TO_BE_16((frm_chnk_p)->id); \
+- } while(0)
+-
+-#define FLX_HDR_FIX_ENDIANNESS(hdr_p) \
+- do { \
+- (hdr_p)->size = LE_TO_BE_32((hdr_p)->size); \
+- (hdr_p)->type = LE_TO_BE_16((hdr_p)->type); \
+- (hdr_p)->frames = LE_TO_BE_16((hdr_p)->frames); \
+- (hdr_p)->width = LE_TO_BE_16((hdr_p)->width); \
+- (hdr_p)->height = LE_TO_BE_16((hdr_p)->height); \
+- (hdr_p)->depth = LE_TO_BE_16((hdr_p)->depth); \
+- (hdr_p)->flags = LE_TO_BE_16((hdr_p)->flags); \
+- (hdr_p)->speed = LE_TO_BE_32((hdr_p)->speed); \
+- (hdr_p)->reserved1 = LE_TO_BE_16((hdr_p)->reserved1); \
+- (hdr_p)->created = LE_TO_BE_32((hdr_p)->created); \
+- (hdr_p)->creator = LE_TO_BE_32((hdr_p)->creator); \
+- (hdr_p)->updated = LE_TO_BE_32((hdr_p)->updated); \
+- (hdr_p)->updater = LE_TO_BE_32((hdr_p)->updater); \
+- (hdr_p)->aspect_dx = LE_TO_BE_16((hdr_p)->aspect_dx); \
+- (hdr_p)->aspect_dy = LE_TO_BE_16((hdr_p)->aspect_dy); \
+- (hdr_p)->ext_flags = LE_TO_BE_16((hdr_p)->ext_flags); \
+- (hdr_p)->keyframes = LE_TO_BE_16((hdr_p)->keyframes); \
+- (hdr_p)->totalframes = LE_TO_BE_16((hdr_p)->totalframes); \
+- (hdr_p)->req_memory = LE_TO_BE_32((hdr_p)->req_memory); \
+- (hdr_p)->max_regions = LE_TO_BE_16((hdr_p)->max_regions); \
+- (hdr_p)->transp_num = LE_TO_BE_16((hdr_p)->transp_num); \
+- (hdr_p)->oframe1 = LE_TO_BE_32((hdr_p)->oframe1); \
+- (hdr_p)->oframe2 = LE_TO_BE_32((hdr_p)->oframe2); \
+- } while(0)
+-#else
+-
+-#define LE_TO_BE_16(i16) ((i16))
+-#define LE_TO_BE_32(i32) ((i32))
+-
+-#define FLX_FRAME_TYPE_FIX_ENDIANNESS(frm_type_p)
+-#define FLX_HUFFMAN_TABLE_FIX_ENDIANNESS(hffmn_table_p)
+-#define FLX_SEGMENT_TABLE_FIX_ENDIANNESS(sgmnt_table_p)
+-#define FLX_PREFIX_CHUNK_FIX_ENDIANNESS(prfx_chnk_p)
+-#define FLX_FRAME_CHUNK_FIX_ENDIANNESS(frm_chnk_p)
+-#define FLX_HDR_FIX_ENDIANNESS(hdr_p)
+-
+-#endif /* G_BYTE_ORDER == G_BIG_ENDIAN */
+-
+ G_END_DECLS
+
+ #endif /* __GST_FLX_FMT_H__ */
+diff --git a/gst/flx/gstflxdec.c b/gst/flx/gstflxdec.c
+index a237976..aa1bed5 100644
+--- a/gst/flx/gstflxdec.c
++++ b/gst/flx/gstflxdec.c
+@@ -1,5 +1,6 @@
+ /* GStreamer
+ * Copyright (C) <1999> Erik Walthinsen <omega@temple-baptist.com>
++ * Copyright (C) <2016> Matthew Waters <matthew@centricular.com>
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Library General Public
+@@ -24,6 +25,7 @@
+ /*
+ * http://www.coolutils.com/Formats/FLI
+ * http://woodshole.er.usgs.gov/operations/modeling/flc.html
++ * http://www.compuphase.com/flic.htm
+ */
+
+ #ifdef HAVE_CONFIG_H
+@@ -73,10 +75,14 @@ static GstStateChangeReturn gst_flxdec_change_state (GstElement * element,
+ static gboolean gst_flxdec_src_query_handler (GstPad * pad, GstObject * parent,
+ GstQuery * query);
+
+-static void flx_decode_color (GstFlxDec *, guchar *, guchar *, gint);
+-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 *);
++static gboolean flx_decode_color (GstFlxDec * flxdec, GstByteReader * reader,
++ GstByteWriter * writer, gint scale);
++static gboolean flx_decode_brun (GstFlxDec * flxdec,
++ GstByteReader * reader, GstByteWriter * writer);
++static gboolean flx_decode_delta_fli (GstFlxDec * flxdec,
++ GstByteReader * reader, GstByteWriter * writer);
++static gboolean flx_decode_delta_flc (GstFlxDec * flxdec,
++ GstByteReader * reader, GstByteWriter * writer);
+
+ #define rndalign(off) ((off) + ((off) & 1))
+
+@@ -204,57 +210,59 @@ gst_flxdec_sink_event_handler (GstPad * pad, GstObject * parent,
+ }
+
+ static gboolean
+-flx_decode_chunks (GstFlxDec * flxdec, gulong count, guchar * data,
+- guchar * dest)
++flx_decode_chunks (GstFlxDec * flxdec, gulong n_chunks, GstByteReader * reader,
++ GstByteWriter * writer)
+ {
+- FlxFrameChunk *hdr;
+ gboolean ret = TRUE;
+
+- g_return_val_if_fail (data != NULL, FALSE);
+-
+- while (count--) {
+- hdr = (FlxFrameChunk *) data;
+- FLX_FRAME_CHUNK_FIX_ENDIANNESS (hdr);
+- data += FlxFrameChunkSize;
++ while (n_chunks--) {
++ GstByteReader chunk;
++ guint32 size;
++ guint16 type;
++
++ if (!gst_byte_reader_get_uint32_le (reader, &size))
++ goto parse_error;
++ if (!gst_byte_reader_get_uint16_le (reader, &type))
++ goto parse_error;
++ GST_LOG_OBJECT (flxdec, "chunk has type 0x%02x size %d", type, size);
++
++ if (!gst_byte_reader_get_sub_reader (reader, &chunk,
++ size - FlxFrameChunkSize)) {
++ GST_ERROR_OBJECT (flxdec, "Incorrect size in the chunk header");
++ goto error;
++ }
+
+- switch (hdr->id) {
++ switch (type) {
+ case FLX_COLOR64:
+- flx_decode_color (flxdec, data, dest, 2);
+- data += rndalign (hdr->size) - FlxFrameChunkSize;
++ ret = flx_decode_color (flxdec, &chunk, writer, 2);
+ break;
+
+ case FLX_COLOR256:
+- flx_decode_color (flxdec, data, dest, 0);
+- data += rndalign (hdr->size) - FlxFrameChunkSize;
++ ret = flx_decode_color (flxdec, &chunk, writer, 0);
+ break;
+
+ case FLX_BRUN:
+- ret = flx_decode_brun (flxdec, data, dest);
+- data += rndalign (hdr->size) - FlxFrameChunkSize;
++ ret = flx_decode_brun (flxdec, &chunk, writer);
+ break;
+
+ case FLX_LC:
+- ret = flx_decode_delta_fli (flxdec, data, dest);
+- data += rndalign (hdr->size) - FlxFrameChunkSize;
++ ret = flx_decode_delta_fli (flxdec, &chunk, writer);
+ break;
+
+ case FLX_SS2:
+- ret = flx_decode_delta_flc (flxdec, data, dest);
+- data += rndalign (hdr->size) - FlxFrameChunkSize;
++ ret = flx_decode_delta_flc (flxdec, &chunk, writer);
+ break;
+
+ case FLX_BLACK:
+- memset (dest, 0, flxdec->size);
++ ret = gst_byte_writer_fill (writer, 0, flxdec->size);
+ break;
+
+ case FLX_MINI:
+- data += rndalign (hdr->size) - FlxFrameChunkSize;
+ break;
+
+ default:
+- GST_WARNING ("Unimplented chunk type: 0x%02x size: %d - skipping",
+- hdr->id, hdr->size);
+- data += rndalign (hdr->size) - FlxFrameChunkSize;
++ GST_WARNING ("Unimplemented chunk type: 0x%02x size: %d - skipping",
++ type, size);
+ break;
+ }
+
+@@ -263,43 +271,60 @@ flx_decode_chunks (GstFlxDec * flxdec, gulong count, guchar * data,
+ }
+
+ return ret;
++
++parse_error:
++ GST_ERROR_OBJECT (flxdec, "Failed to decode chunk");
++error:
++ return FALSE;
+ }
+
+
+-static void
+-flx_decode_color (GstFlxDec * flxdec, guchar * data, guchar * dest, gint scale)
++static gboolean
++flx_decode_color (GstFlxDec * flxdec, GstByteReader * reader,
++ GstByteWriter * writer, gint scale)
+ {
+- guint packs, count, indx;
++ guint8 count, indx;
++ guint16 packs;
+
+- g_return_if_fail (flxdec != NULL);
+-
+- packs = (data[0] + (data[1] << 8));
+-
+- data += 2;
++ if (!gst_byte_reader_get_uint16_le (reader, &packs))
++ goto error;
+ indx = 0;
+
+- GST_LOG ("GstFlxDec: cmap packs: %d", packs);
++ GST_LOG ("GstFlxDec: cmap packs: %d", (guint) packs);
+ while (packs--) {
++ const guint8 *data;
++ guint16 actual_count;
++
+ /* color map index + skip count */
+- indx += *data++;
++ if (!gst_byte_reader_get_uint8 (reader, &indx))
++ goto error;
+
+ /* number of rgb triplets */
+- count = *data++ & 0xff;
+- if (count == 0)
+- count = 256;
++ if (!gst_byte_reader_get_uint8 (reader, &count))
++ goto error;
+
+- GST_LOG ("GstFlxDec: cmap count: %d (indx: %d)", count, indx);
+- flx_set_palette_vector (flxdec->converter, indx, count, data, scale);
++ actual_count = count == 0 ? 256 : count;
+
+- data += (count * 3);
++ if (!gst_byte_reader_get_data (reader, count * 3, &data))
++ goto error;
++
++ GST_LOG_OBJECT (flxdec, "cmap count: %d (indx: %d)", actual_count, indx);
++ flx_set_palette_vector (flxdec->converter, indx, actual_count,
++ (guchar *) data, scale);
+ }
++
++ return TRUE;
++
++error:
++ GST_ERROR_OBJECT (flxdec, "Error decoding color palette");
++ return FALSE;
+ }
+
+ static gboolean
+-flx_decode_brun (GstFlxDec * flxdec, guchar * data, guchar * dest)
++flx_decode_brun (GstFlxDec * flxdec, GstByteReader * reader,
++ GstByteWriter * writer)
+ {
+- gulong count, lines, row;
+- guchar x;
++ gulong lines, row;
+
+ g_return_val_if_fail (flxdec != NULL, FALSE);
+
+@@ -310,82 +335,125 @@ flx_decode_brun (GstFlxDec * flxdec, guchar * data, guchar * dest)
+ * contain more then 255 RLE packets. we use the frame
+ * width instead.
+ */
+- data++;
++ if (!gst_byte_reader_skip (reader, 1))
++ goto error;
+
+ row = flxdec->hdr.width;
+ while (row) {
+- count = *data++;
++ gint8 count;
++
++ if (!gst_byte_reader_get_int8 (reader, &count))
++ goto error;
++
++ if (count <= 0) {
++ const guint8 *data;
+
+- if (count > 0x7f) {
+ /* literal run */
+- count = 0x100 - count;
+- if ((glong) row - (glong) count < 0) {
+- GST_ERROR_OBJECT (flxdec, "Invalid BRUN packet detected.");
++ count = ABS (count);
++
++ GST_LOG_OBJECT (flxdec, "have literal run of size %d", count);
++
++ if (count > row) {
++ GST_ERROR_OBJECT (flxdec, "Invalid BRUN line detected. "
++ "bytes to write exceeds the end of the row");
+ return FALSE;
+ }
+ row -= count;
+
+- while (count--)
+- *dest++ = *data++;
+-
++ if (!gst_byte_reader_get_data (reader, count, &data))
++ goto error;
++ if (!gst_byte_writer_put_data (writer, data, count))
++ goto error;
+ } else {
+- if ((glong) row - (glong) count < 0) {
+- GST_ERROR_OBJECT (flxdec, "Invalid BRUN packet detected.");
++ guint8 x;
++
++ GST_LOG_OBJECT (flxdec, "have replicate run of size %d", count);
++
++ if (count > row) {
++ GST_ERROR_OBJECT (flxdec, "Invalid BRUN packet detected."
++ "bytes to write exceeds the end of the row");
+ return FALSE;
+ }
+
+ /* replicate run */
+ row -= count;
+- x = *data++;
+
+- while (count--)
+- *dest++ = x;
++ if (!gst_byte_reader_get_uint8 (reader, &x))
++ goto error;
++ if (!gst_byte_writer_fill (writer, x, count))
++ goto error;
+ }
+ }
+ }
+
+ return TRUE;
++
++error:
++ GST_ERROR_OBJECT (flxdec, "Failed to decode BRUN packet");
++ return FALSE;
+ }
+
+ static gboolean
+-flx_decode_delta_fli (GstFlxDec * flxdec, guchar * data, guchar * dest)
++flx_decode_delta_fli (GstFlxDec * flxdec, GstByteReader * reader,
++ GstByteWriter * writer)
+ {
+- gulong count, packets, lines, start_line;
+- guchar *start_p, x;
++ guint16 start_line, lines;
++ guint line_start_i;
+
+ 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);
++ if (!gst_byte_writer_put_data (writer, flxdec->delta_data, flxdec->size))
++ goto error;
++
++ if (!gst_byte_reader_get_uint16_le (reader, &start_line))
++ goto error;
++ if (!gst_byte_reader_get_uint16_le (reader, &lines))
++ goto error;
++ GST_LOG_OBJECT (flxdec, "height %d start line %d line count %d",
++ flxdec->hdr.height, start_line, lines);
+
+- 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 */
+- dest += (flxdec->hdr.width * start_line);
+- start_p = dest;
++ line_start_i = flxdec->hdr.width * start_line;
++ if (!gst_byte_writer_set_pos (writer, line_start_i))
++ goto error;
+
+ while (lines--) {
++ guint8 packets;
++
+ /* packet count */
+- packets = *data++;
++ if (!gst_byte_reader_get_uint8 (reader, &packets))
++ goto error;
++ GST_LOG_OBJECT (flxdec, "have %d packets", packets);
+
+ while (packets--) {
+ /* skip count */
+- guchar skip = *data++;
+- dest += skip;
++ guint8 skip;
++ gint8 count;
++ if (!gst_byte_reader_get_uint8 (reader, &skip))
++ goto error;
++
++ /* skip bytes */
++ if (!gst_byte_writer_set_pos (writer,
++ gst_byte_writer_get_pos (writer) + skip))
++ goto error;
+
+ /* RLE count */
+- count = *data++;
++ if (!gst_byte_reader_get_int8 (reader, &count))
++ goto error;
++
++ if (count < 0) {
++ guint8 x;
+
+- if (count > 0x7f) {
+ /* literal run */
+- count = 0x100 - count;
++ count = ABS (count);
++ GST_LOG_OBJECT (flxdec, "have literal run of size %d at offset %d",
++ count, skip);
+
+ if (skip + count > flxdec->hdr.width) {
+ GST_ERROR_OBJECT (flxdec, "Invalid FLI packet detected. "
+@@ -393,11 +461,16 @@ flx_decode_delta_fli (GstFlxDec * flxdec, guchar * data, guchar * dest)
+ return FALSE;
+ }
+
+- x = *data++;
+- while (count--)
+- *dest++ = x;
+-
++ if (!gst_byte_reader_get_uint8 (reader, &x))
++ goto error;
++ if (!gst_byte_writer_fill (writer, x, count))
++ goto error;
+ } else {
++ const guint8 *data;
++
++ GST_LOG_OBJECT (flxdec, "have replicate run of size %d at offset %d",
++ count, skip);
++
+ if (skip + count > flxdec->hdr.width) {
+ GST_ERROR_OBJECT (flxdec, "Invalid FLI packet detected. "
+ "line too long.");
+@@ -405,45 +478,60 @@ flx_decode_delta_fli (GstFlxDec * flxdec, guchar * data, guchar * dest)
+ }
+
+ /* replicate run */
+- while (count--)
+- *dest++ = *data++;
++ if (!gst_byte_reader_get_data (reader, count, &data))
++ goto error;
++ if (!gst_byte_writer_put_data (writer, data, count))
++ goto error;
+ }
+ }
+- start_p += flxdec->hdr.width;
+- dest = start_p;
++ line_start_i += flxdec->hdr.width;
++ if (!gst_byte_writer_set_pos (writer, line_start_i))
++ goto error;
+ }
+
+ return TRUE;
++
++error:
++ GST_ERROR_OBJECT (flxdec, "Failed to decode FLI packet");
++ return FALSE;
+ }
+
+ static gboolean
+-flx_decode_delta_flc (GstFlxDec * flxdec, guchar * data, guchar * dest)
++flx_decode_delta_flc (GstFlxDec * flxdec, GstByteReader * reader,
++ GstByteWriter * writer)
+ {
+- gulong count, lines, start_l, opcode;
+- guchar *start_p;
++ guint16 lines, start_l;
+
+ 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);
++ if (!gst_byte_writer_put_data (writer, flxdec->delta_data, flxdec->size))
++ goto error;
++ if (!gst_byte_reader_get_uint16_le (reader, &lines))
++ goto error;
+
+- 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;
+ start_l = lines;
+
+ while (lines) {
+- dest = start_p + (flxdec->hdr.width * (start_l - lines));
++ guint16 opcode;
++
++ if (!gst_byte_writer_set_pos (writer,
++ flxdec->hdr.width * (start_l - lines)))
++ goto error;
+
+ /* process opcode(s) */
+- while ((opcode = (data[0] + (data[1] << 8))) & 0xc000) {
+- data += 2;
++ while (TRUE) {
++ if (!gst_byte_reader_get_uint16_le (reader, &opcode))
++ goto error;
++ if ((opcode & 0xc000) == 0)
++ break;
++
+ if ((opcode & 0xc000) == 0xc000) {
+ /* line skip count */
+ gulong skip = (0x10000 - opcode);
+@@ -453,27 +541,44 @@ flx_decode_delta_flc (GstFlxDec * flxdec, guchar * data, guchar * dest)
+ return FALSE;
+ }
+ start_l += skip;
+- dest += flxdec->hdr.width * skip;
++ if (!gst_byte_writer_set_pos (writer,
++ gst_byte_writer_get_pos (writer) + flxdec->hdr.width * skip))
++ goto error;
+ } else {
+ /* last pixel */
+- dest += flxdec->hdr.width;
+- *dest++ = (opcode & 0xff);
++ if (!gst_byte_writer_set_pos (writer,
++ gst_byte_writer_get_pos (writer) + flxdec->hdr.width))
++ goto error;
++ if (!gst_byte_writer_put_uint8 (writer, opcode & 0xff))
++ goto error;
+ }
+ }
+- data += 2;
+
+ /* last opcode is the packet count */
++ GST_LOG_OBJECT (flxdec, "have %d packets", opcode);
+ while (opcode--) {
+ /* skip count */
+- guchar skip = *data++;
+- dest += skip;
++ guint8 skip;
++ gint8 count;
++
++ if (!gst_byte_reader_get_uint8 (reader, &skip))
++ goto error;
++ if (!gst_byte_writer_set_pos (writer,
++ gst_byte_writer_get_pos (writer) + skip))
++ goto error;
+
+ /* RLE count */
+- count = *data++;
++ if (!gst_byte_reader_get_int8 (reader, &count))
++ goto error;
++
++ if (count < 0) {
++ guint16 x;
+
+- if (count > 0x7f) {
+ /* replicate word run */
+- count = 0x100 - count;
++ count = ABS (count);
++
++ GST_LOG_OBJECT (flxdec, "have replicate run of size %d at offset %d",
++ count, skip);
+
+ if (skip + count > flxdec->hdr.width) {
+ GST_ERROR_OBJECT (flxdec, "Invalid FLC packet detected. "
+@@ -481,22 +586,31 @@ flx_decode_delta_flc (GstFlxDec * flxdec, guchar * data, guchar * dest)
+ return FALSE;
+ }
+
++ if (!gst_byte_reader_get_uint16_le (reader, &x))
++ goto error;
++
+ while (count--) {
+- *dest++ = data[0];
+- *dest++ = data[1];
++ if (!gst_byte_writer_put_uint16_le (writer, x)) {
++ goto error;
++ }
+ }
+- data += 2;
+ } else {
++ GST_LOG_OBJECT (flxdec, "have literal run of size %d at offset %d",
++ count, skip);
++
+ 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++;
+- *dest++ = *data++;
++ guint16 x;
++
++ if (!gst_byte_reader_get_uint16_le (reader, &x))
++ goto error;
++ if (!gst_byte_writer_put_uint16_le (writer, x))
++ goto error;
+ }
+ }
+ }
+@@ -504,13 +618,91 @@ flx_decode_delta_flc (GstFlxDec * flxdec, guchar * data, guchar * dest)
+ }
+
+ return TRUE;
++
++error:
++ GST_ERROR_OBJECT (flxdec, "Failed to decode FLI packet");
++ return FALSE;
++}
++
++static gboolean
++_read_flx_header (GstFlxDec * flxdec, GstByteReader * reader, FlxHeader * flxh)
++{
++ memset (flxh, 0, sizeof (*flxh));
++
++ if (!gst_byte_reader_get_uint32_le (reader, &flxh->size))
++ goto error;
++ if (flxh->size < FlxHeaderSize) {
++ GST_ERROR_OBJECT (flxdec, "Invalid file size in the header");
++ return FALSE;
++ }
++
++ if (!gst_byte_reader_get_uint16_le (reader, &flxh->type))
++ goto error;
++ if (!gst_byte_reader_get_uint16_le (reader, &flxh->frames))
++ goto error;
++ if (!gst_byte_reader_get_uint16_le (reader, &flxh->width))
++ goto error;
++ if (!gst_byte_reader_get_uint16_le (reader, &flxh->height))
++ goto error;
++ if (!gst_byte_reader_get_uint16_le (reader, &flxh->depth))
++ goto error;
++ if (!gst_byte_reader_get_uint16_le (reader, &flxh->flags))
++ goto error;
++ if (!gst_byte_reader_get_uint32_le (reader, &flxh->speed))
++ goto error;
++ if (!gst_byte_reader_skip (reader, 2)) /* reserved */
++ goto error;
++ /* FLC */
++ if (!gst_byte_reader_get_uint32_le (reader, &flxh->created))
++ goto error;
++ if (!gst_byte_reader_get_uint32_le (reader, &flxh->creator))
++ goto error;
++ if (!gst_byte_reader_get_uint32_le (reader, &flxh->updated))
++ goto error;
++ if (!gst_byte_reader_get_uint32_le (reader, &flxh->updater))
++ goto error;
++ if (!gst_byte_reader_get_uint16_le (reader, &flxh->aspect_dx))
++ goto error;
++ if (!gst_byte_reader_get_uint16_le (reader, &flxh->aspect_dy))
++ goto error;
++ /* EGI */
++ if (!gst_byte_reader_get_uint16_le (reader, &flxh->ext_flags))
++ goto error;
++ if (!gst_byte_reader_get_uint16_le (reader, &flxh->keyframes))
++ goto error;
++ if (!gst_byte_reader_get_uint16_le (reader, &flxh->totalframes))
++ goto error;
++ if (!gst_byte_reader_get_uint32_le (reader, &flxh->req_memory))
++ goto error;
++ if (!gst_byte_reader_get_uint16_le (reader, &flxh->max_regions))
++ goto error;
++ if (!gst_byte_reader_get_uint16_le (reader, &flxh->transp_num))
++ goto error;
++ if (!gst_byte_reader_skip (reader, 24)) /* reserved */
++ goto error;
++ /* FLC */
++ if (!gst_byte_reader_get_uint32_le (reader, &flxh->oframe1))
++ goto error;
++ if (!gst_byte_reader_get_uint32_le (reader, &flxh->oframe2))
++ goto error;
++ if (!gst_byte_reader_skip (reader, 40)) /* reserved */
++ goto error;
++
++ return TRUE;
++
++error:
++ GST_ERROR_OBJECT (flxdec, "Error reading file header");
++ return FALSE;
+ }
+
+ static GstFlowReturn
+ gst_flxdec_chain (GstPad * pad, GstObject * parent, GstBuffer * buf)
+ {
++ GstByteReader reader;
++ GstBuffer *input;
++ GstMapInfo map_info;
+ GstCaps *caps;
+- guint avail;
++ guint available;
+ GstFlowReturn res = GST_FLOW_OK;
+
+ GstFlxDec *flxdec;
+@@ -521,31 +713,50 @@ gst_flxdec_chain (GstPad * pad, GstObject * parent, GstBuffer * buf)
+ g_return_val_if_fail (flxdec != NULL, GST_FLOW_ERROR);
+
+ gst_adapter_push (flxdec->adapter, buf);
+- avail = gst_adapter_available (flxdec->adapter);
++ available = gst_adapter_available (flxdec->adapter);
++ input = gst_adapter_get_buffer (flxdec->adapter, available);
++ if (!gst_buffer_map (input, &map_info, GST_MAP_READ)) {
++ GST_ELEMENT_ERROR (flxdec, STREAM, DECODE,
++ ("%s", "Failed to map buffer"), (NULL));
++ goto error;
++ }
++ gst_byte_reader_init (&reader, map_info.data, map_info.size);
+
+ if (flxdec->state == GST_FLXDEC_READ_HEADER) {
+- if (avail >= FlxHeaderSize) {
+- const guint8 *data = gst_adapter_map (flxdec->adapter, FlxHeaderSize);
++ if (available >= FlxHeaderSize) {
++ GstByteReader header;
+ GstCaps *templ;
+
+- memcpy ((gchar *) & flxdec->hdr, data, FlxHeaderSize);
+- FLX_HDR_FIX_ENDIANNESS (&(flxdec->hdr));
+- gst_adapter_unmap (flxdec->adapter);
++ if (!gst_byte_reader_get_sub_reader (&reader, &header, FlxHeaderSize)) {
++ GST_ELEMENT_ERROR (flxdec, STREAM, DECODE,
++ ("%s", "Could not read header"), (NULL));
++ goto unmap_input_error;
++ }
+ gst_adapter_flush (flxdec->adapter, FlxHeaderSize);
++ available -= FlxHeaderSize;
++
++ if (!_read_flx_header (flxdec, &header, &flxdec->hdr)) {
++ GST_ELEMENT_ERROR (flxdec, STREAM, DECODE,
++ ("%s", "Failed to parse header"), (NULL));
++ goto unmap_input_error;
++ }
+
+ flxh = &flxdec->hdr;
+
+ /* check header */
+ if (flxh->type != FLX_MAGICHDR_FLI &&
+- flxh->type != FLX_MAGICHDR_FLC && flxh->type != FLX_MAGICHDR_FLX)
+- goto wrong_type;
++ flxh->type != FLX_MAGICHDR_FLC && flxh->type != FLX_MAGICHDR_FLX) {
++ GST_ELEMENT_ERROR (flxdec, STREAM, WRONG_TYPE, (NULL),
++ ("not a flx file (type %x)", flxh->type));
++ goto unmap_input_error;
++ }
+
+- GST_LOG ("size : %d", flxh->size);
+- GST_LOG ("frames : %d", flxh->frames);
+- GST_LOG ("width : %d", flxh->width);
+- GST_LOG ("height : %d", flxh->height);
+- GST_LOG ("depth : %d", flxh->depth);
+- GST_LOG ("speed : %d", flxh->speed);
++ GST_INFO_OBJECT (flxdec, "size : %d", flxh->size);
++ GST_INFO_OBJECT (flxdec, "frames : %d", flxh->frames);
++ GST_INFO_OBJECT (flxdec, "width : %d", flxh->width);
++ GST_INFO_OBJECT (flxdec, "height : %d", flxh->height);
++ GST_INFO_OBJECT (flxdec, "depth : %d", flxh->depth);
++ GST_INFO_OBJECT (flxdec, "speed : %d", flxh->speed);
+
+ flxdec->next_time = 0;
+
+@@ -573,18 +784,32 @@ gst_flxdec_chain (GstPad * pad, GstObject * parent, GstBuffer * buf)
+ gst_pad_set_caps (flxdec->srcpad, caps);
+ gst_caps_unref (caps);
+
+- if (flxh->depth <= 8)
+- flxdec->converter =
+- flx_colorspace_converter_new (flxh->width, flxh->height);
++ /* zero means 8 */
++ if (flxh->depth == 0)
++ flxh->depth = 8;
++
++ if (flxh->depth != 8) {
++ GST_ELEMENT_ERROR (flxdec, STREAM, WRONG_TYPE,
++ ("%s", "Don't know how to decode non 8 bit depth streams"), (NULL));
++ goto unmap_input_error;
++ }
++
++ flxdec->converter =
++ flx_colorspace_converter_new (flxh->width, flxh->height);
+
+ if (flxh->type == FLX_MAGICHDR_FLC || flxh->type == FLX_MAGICHDR_FLX) {
+- GST_LOG ("(FLC) aspect_dx : %d", flxh->aspect_dx);
+- GST_LOG ("(FLC) aspect_dy : %d", flxh->aspect_dy);
+- GST_LOG ("(FLC) oframe1 : 0x%08x", flxh->oframe1);
+- GST_LOG ("(FLC) oframe2 : 0x%08x", flxh->oframe2);
++ GST_INFO_OBJECT (flxdec, "(FLC) aspect_dx : %d", flxh->aspect_dx);
++ GST_INFO_OBJECT (flxdec, "(FLC) aspect_dy : %d", flxh->aspect_dy);
++ GST_INFO_OBJECT (flxdec, "(FLC) oframe1 : 0x%08x", flxh->oframe1);
++ GST_INFO_OBJECT (flxdec, "(FLC) oframe2 : 0x%08x", flxh->oframe2);
+ }
+
+ flxdec->size = ((guint) flxh->width * (guint) flxh->height);
++ if (flxdec->size >= G_MAXSIZE / 4) {
++ GST_ELEMENT_ERROR (flxdec, STREAM, DECODE,
++ ("%s", "Cannot allocate required memory"), (NULL));
++ goto unmap_input_error;
++ }
+
+ /* create delta and output frame */
+ flxdec->frame_data = g_malloc (flxdec->size);
+@@ -596,55 +821,66 @@ gst_flxdec_chain (GstPad * pad, GstObject * parent, GstBuffer * buf)
+ GstBuffer *out;
+
+ /* while we have enough data in the adapter */
+- while (avail >= FlxFrameChunkSize && res == GST_FLOW_OK) {
+- FlxFrameChunk flxfh;
+- guchar *chunk;
+- const guint8 *data;
+- GstMapInfo map;
+-
+- chunk = NULL;
+- data = gst_adapter_map (flxdec->adapter, FlxFrameChunkSize);
+- memcpy (&flxfh, data, FlxFrameChunkSize);
+- FLX_FRAME_CHUNK_FIX_ENDIANNESS (&flxfh);
+- gst_adapter_unmap (flxdec->adapter);
+-
+- switch (flxfh.id) {
+- case FLX_FRAME_TYPE:
+- /* check if we have the complete frame */
+- if (avail < flxfh.size)
+- goto need_more_data;
+-
+- /* flush header */
+- gst_adapter_flush (flxdec->adapter, FlxFrameChunkSize);
+-
+- chunk = gst_adapter_take (flxdec->adapter,
+- flxfh.size - FlxFrameChunkSize);
+- FLX_FRAME_TYPE_FIX_ENDIANNESS ((FlxFrameType *) chunk);
+- if (((FlxFrameType *) chunk)->chunks == 0)
+- break;
++ while (available >= FlxFrameChunkSize && res == GST_FLOW_OK) {
++ guint32 size;
++ guint16 type;
+
+- /* create 32 bits output frame */
+-// res = gst_pad_alloc_buffer_and_set_caps (flxdec->srcpad,
+-// GST_BUFFER_OFFSET_NONE,
+-// flxdec->size * 4, GST_PAD_CAPS (flxdec->srcpad), &out);
+-// if (res != GST_FLOW_OK)
+-// break;
++ if (!gst_byte_reader_get_uint32_le (&reader, &size))
++ goto parse_error;
++ if (available < size)
++ goto need_more_data;
+
+- out = gst_buffer_new_and_alloc (flxdec->size * 4);
++ available -= size;
++ gst_adapter_flush (flxdec->adapter, size);
++
++ if (!gst_byte_reader_get_uint16_le (&reader, &type))
++ goto parse_error;
++
++ switch (type) {
++ case FLX_FRAME_TYPE:{
++ GstByteReader chunks;
++ GstByteWriter writer;
++ guint16 n_chunks;
++ GstMapInfo map;
++
++ GST_LOG_OBJECT (flxdec, "Have frame type 0x%02x of size %d", type,
++ size);
++
++ if (!gst_byte_reader_get_sub_reader (&reader, &chunks,
++ size - FlxFrameChunkSize))
++ goto parse_error;
++
++ if (!gst_byte_reader_get_uint16_le (&chunks, &n_chunks))
++ goto parse_error;
++ GST_LOG_OBJECT (flxdec, "Have %d chunks", n_chunks);
++
++ if (n_chunks == 0)
++ break;
++ if (!gst_byte_reader_skip (&chunks, 8)) /* reserved */
++ goto parse_error;
++
++ gst_byte_writer_init_with_data (&writer, flxdec->frame_data,
++ flxdec->size, TRUE);
+
+ /* decode chunks */
+- if (!flx_decode_chunks (flxdec,
+- ((FlxFrameType *) chunk)->chunks,
+- chunk + FlxFrameTypeSize, flxdec->frame_data)) {
++ if (!flx_decode_chunks (flxdec, n_chunks, &chunks, &writer)) {
+ GST_ELEMENT_ERROR (flxdec, STREAM, DECODE,
+ ("%s", "Could not decode chunk"), NULL);
+- return GST_FLOW_ERROR;
++ goto unmap_input_error;
+ }
++ gst_byte_writer_reset (&writer);
+
+ /* save copy of the current frame for possible delta. */
+ memcpy (flxdec->delta_data, flxdec->frame_data, flxdec->size);
+
+- gst_buffer_map (out, &map, GST_MAP_WRITE);
++ out = gst_buffer_new_and_alloc (flxdec->size * 4);
++ if (!gst_buffer_map (out, &map, GST_MAP_WRITE)) {
++ GST_ELEMENT_ERROR (flxdec, STREAM, DECODE,
++ ("%s", "Could not map output buffer"), NULL);
++ gst_buffer_unref (out);
++ goto unmap_input_error;
++ }
++
+ /* convert current frame. */
+ flx_colorspace_convert (flxdec->converter, flxdec->frame_data,
+ map.data);
+@@ -655,30 +891,32 @@ gst_flxdec_chain (GstPad * pad, GstObject * parent, GstBuffer * buf)
+
+ res = gst_pad_push (flxdec->srcpad, out);
+ break;
++ }
+ default:
+- /* check if we have the complete frame */
+- if (avail < flxfh.size)
+- goto need_more_data;
+-
+- gst_adapter_flush (flxdec->adapter, flxfh.size);
++ GST_DEBUG_OBJECT (flxdec, "Unknown frame type 0x%02x, skipping %d",
++ type, size);
++ if (!gst_byte_reader_skip (&reader, size - FlxFrameChunkSize))
++ goto parse_error;
+ break;
+ }
+-
+- g_free (chunk);
+-
+- avail = gst_adapter_available (flxdec->adapter);
+ }
+ }
++
++ gst_buffer_unmap (input, &map_info);
++ gst_buffer_unref (input);
++
+ need_more_data:
+ return res;
+
+ /* ERRORS */
+-wrong_type:
+- {
+- GST_ELEMENT_ERROR (flxdec, STREAM, WRONG_TYPE, (NULL),
+- ("not a flx file (type %x)", flxh->type));
+- return GST_FLOW_ERROR;
+- }
++parse_error:
++ GST_ELEMENT_ERROR (flxdec, STREAM, DECODE,
++ ("%s", "Failed to parse stream"), (NULL));
++unmap_input_error:
++ gst_buffer_unmap (input, &map_info);
++ gst_buffer_unref (input);
++error:
++ return GST_FLOW_ERROR;
+ }
+
+ static GstStateChangeReturn
+diff --git a/gst/flx/gstflxdec.h b/gst/flx/gstflxdec.h
+index 3f9a0aa..4fd8dfd 100644
+--- a/gst/flx/gstflxdec.h
++++ b/gst/flx/gstflxdec.h
+@@ -23,6 +23,8 @@
+ #include <gst/gst.h>
+
+ #include <gst/base/gstadapter.h>
++#include <gst/base/gstbytereader.h>
++#include <gst/base/gstbytewriter.h>
+ #include "flx_color.h"
+
+ G_BEGIN_DECLS
+@@ -45,7 +47,7 @@ struct _GstFlxDec {
+
+ guint8 *delta_data, *frame_data;
+ GstAdapter *adapter;
+- gulong size;
++ gsize size;
+ GstFlxDecState state;
+ gint64 frame_time;
+ gint64 next_time;
+--
+2.10.2
+
diff --git a/gnu/packages/patches/gst-plugins-good-fix-invalid-read.patch b/gnu/packages/patches/gst-plugins-good-fix-invalid-read.patch
new file mode 100644
index 0000000000..1daaa2ae15
--- /dev/null
+++ b/gnu/packages/patches/gst-plugins-good-fix-invalid-read.patch
@@ -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
+
diff --git a/gnu/packages/patches/gst-plugins-good-fix-signedness.patch b/gnu/packages/patches/gst-plugins-good-fix-signedness.patch
new file mode 100644
index 0000000000..a3e20e19dd
--- /dev/null
+++ b/gnu/packages/patches/gst-plugins-good-fix-signedness.patch
@@ -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
+
diff --git a/gnu/packages/patches/gst-plugins-good-flic-bounds-check.patch b/gnu/packages/patches/gst-plugins-good-flic-bounds-check.patch
new file mode 100644
index 0000000000..f77dca2cd6
--- /dev/null
+++ b/gnu/packages/patches/gst-plugins-good-flic-bounds-check.patch
@@ -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
+
diff --git a/gnu/packages/patches/ldc-disable-tests.patch b/gnu/packages/patches/ldc-disable-tests.patch
index 3f5e6c29a1..bdd6e5b76c 100644
--- a/gnu/packages/patches/ldc-disable-tests.patch
+++ b/gnu/packages/patches/ldc-disable-tests.patch
@@ -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
diff --git a/gnu/packages/perl.scm b/gnu/packages/perl.scm
index ab6120142d..e9f3dca15a 100644
--- a/gnu/packages/perl.scm
+++ b/gnu/packages/perl.scm
@@ -7,7 +7,7 @@
;;; Copyright © 2016 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2016 Jochem Raat <jchmrt@riseup.net>
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
-;;; Coypright © 2016 ng0 <ng0@we.make.ritual.n0.is>
+;;; Coypright © 2016 ng0 <ng0@libertad.pw>
;;; Copyright © 2016 Alex Sassmannshausen <alex@pompo.co>
;;; Copyright © 2016 Roel Janssen <roel@gnu.org>
;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com>
@@ -2055,6 +2055,35 @@ each stack frame.")
interface for the RFC 2104 HMAC mechanism.")
(license (package-license perl))))
+(define-public perl-digest-md5
+ (package
+ (name "perl-digest-md5")
+ (version "2.55")
+ (source
+ (origin
+ (method url-fetch)
+ (uri (string-append "mirror://cpan/authors/id/G/GA/GAAS/Digest-MD5-"
+ version ".tar.gz"))
+ (sha256
+ (base32
+ "0g0fklbrm2krswc1xhp4iwn1dhqq71fqh2p5wm8xj9a4s6i9ic83"))))
+ (build-system perl-build-system)
+ (arguments
+ `(#:phases
+ (modify-phases %standard-phases
+ (add-after 'build 'set-permissions
+ (lambda _
+ ;; Make MD5.so read-write so it can be stripped.
+ (chmod "blib/arch/auto/Digest/MD5/MD5.so" #o755))))))
+ (home-page "http://search.cpan.org/dist/Digest-MD5")
+ (synopsis "Perl interface to the MD-5 algorithm")
+ (description
+ "The @code{Digest::MD5} module allows you to use the MD5 Message Digest
+algorithm from within Perl programs. The algorithm takes as
+input a message of arbitrary length and produces as output a
+128-bit \"fingerprint\" or \"message digest\" of the input.")
+ (license (package-license perl))))
+
(define-public perl-digest-sha1
(package
(name "perl-digest-sha1")
diff --git a/gnu/packages/psyc.scm b/gnu/packages/psyc.scm
deleted file mode 100644
index 03df188d1d..0000000000
--- a/gnu/packages/psyc.scm
+++ /dev/null
@@ -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))))
diff --git a/gnu/packages/python.scm b/gnu/packages/python.scm
index 123b30800d..497da52264 100644
--- a/gnu/packages/python.scm
+++ b/gnu/packages/python.scm
@@ -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.
;;;
@@ -453,14 +454,14 @@ pidof, tty, taskset, pmap.")
(define-public python-passlib
(package
(name "python-passlib")
- (version "1.6.5")
+ (version "1.7.0")
(source
(origin
(method url-fetch)
(uri (pypi-uri "passlib" version))
(sha256
(base32
- "1z27wdxs5rj5xhhqfzvzn3yg682irkxw6dcs5jj7mcf97psk8gd8"))))
+ "1vdbqsa1a31s98fxkinl052q8nnpvbxnb83qanxfpi2p6c2zdr0b"))))
(build-system python-build-system)
(native-inputs
`(("python-nose" ,python-nose)
@@ -1180,14 +1181,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
@@ -1426,6 +1427,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
@@ -6697,14 +6723,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)
@@ -9532,18 +9558,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
diff --git a/gnu/packages/qemu.scm b/gnu/packages/qemu.scm
index 3c48b7a278..e429c04244 100644
--- a/gnu/packages/qemu.scm
+++ b/gnu/packages/qemu.scm
@@ -119,7 +119,7 @@
(let ((infodir (string-append out "/share/info")))
(for-each (lambda (info)
(install-file info infodir))
- (find-files "." "\\.info$"))
+ (find-files "." "\\.info"))
#t))))))
(add-before 'check 'make-gtester-verbose
(lambda _
diff --git a/gnu/packages/ssh.scm b/gnu/packages/ssh.scm
index 5fdeeb74a4..ea5ec811d1 100644
--- a/gnu/packages/ssh.scm
+++ b/gnu/packages/ssh.scm
@@ -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
diff --git a/gnu/packages/telephony.scm b/gnu/packages/telephony.scm
index 3d5e58ec2d..6597d26096 100644
--- a/gnu/packages/telephony.scm
+++ b/gnu/packages/telephony.scm
@@ -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))))
diff --git a/gnu/packages/upnp.scm b/gnu/packages/upnp.scm
index c46e905c42..f680a52881 100644
--- a/gnu/packages/upnp.scm
+++ b/gnu/packages/upnp.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in>
+;;; Copyright © 2016 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -27,7 +28,7 @@
(define-public miniupnpc
(package
(name "miniupnpc")
- (version "1.9")
+ (version "2.0")
(source
(origin
(method url-fetch)
@@ -35,7 +36,7 @@
"http://miniupnp.tuxfamily.org/files/miniupnpc-"
version ".tar.gz"))
(sha256
- (base32 "0r24jdqcyf839n30ppimdna0hvybscyziaad7ng99fw0x19y88r9"))))
+ (base32 "0fzrc6fs8vzb2yvk01bd3q5jkarysl7gjlyaqncy3yvfk2wcwd6l"))))
(build-system gnu-build-system)
(native-inputs
`(("python" ,python-2)))
@@ -54,14 +55,22 @@
(string-append "LDFLAGS=-Wl,-rpath="
(assoc-ref %outputs "out") "/lib"))
#:phases
- (alist-delete 'configure %standard-phases)))
+ (modify-phases %standard-phases
+ (delete 'configure)
+ (add-before 'install 'qualify-paths
+ (lambda* (#:key outputs #:allow-other-keys)
+ (substitute* "external-ip.sh"
+ (("upnpc")
+ (string-append (assoc-ref outputs "out") "/bin/upnpc"))))))))
(home-page "http://miniupnp.free.fr/")
- (synopsis "Library implementing the client side UPnP protocol")
+ (synopsis "UPnP protocol client library")
(description
- "MiniUPnPc is a library is useful whenever an application needs to listen
-for incoming connections but is run behind a UPnP enabled router or firewall.
-Examples for such applications include: P2P applications, FTP clients for
-active mode, IRC (for DCC) or IM applications, network games, any server
-software.")
+ "The MiniUPnPc client library facilitates access to the services provided
+by any Universal Plug and Play (UPnP) Internet Gateway Device (IGD) present on
+the network. In UPnP terminology, MiniUPnPc is a UPnP Control Point. It is
+useful whenever an application needs to listen for incoming connections while
+running behind a UPnP-enabled router or firewall. Such applications include
+peer-to-peer applications, active-mode FTP clients, DCC file transfers over
+IRC, instant messaging, network games, and most server software.")
(license
(x11-style "file://LICENSE" "See 'LICENSE' file in the distribution"))))
diff --git a/gnu/packages/video.scm b/gnu/packages/video.scm
index 4eab99b5aa..3b93f27426 100644
--- a/gnu/packages/video.scm
+++ b/gnu/packages/video.scm
@@ -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)
diff --git a/gnu/packages/vim.scm b/gnu/packages/vim.scm
index 678f895917..83c21249b4 100644
--- a/gnu/packages/vim.scm
+++ b/gnu/packages/vim.scm
@@ -49,7 +49,7 @@
(define-public vim
(package
(name "vim")
- (version "8.0.0095")
+ (version "8.0.0101")
(source (origin
(method url-fetch)
(uri (string-append "https://github.com/vim/vim/archive/v"
@@ -57,7 +57,7 @@
(file-name (string-append name "-" version ".tar.gz"))
(sha256
(base32
- "1whib2zzqdpgfhpr7ymqxj3das6iyiapvx0izw4147mkg9yanmp7"))))
+ "0kzk1p5vnqr8j5jwb3p745zx3dki5jwlsp7rh6nli0ci2w6vg3r8"))))
(build-system gnu-build-system)
(arguments
`(#:test-target "test"
diff --git a/gnu/packages/web.scm b/gnu/packages/web.scm
index 063a8a9a15..753a81625c 100644
--- a/gnu/packages/web.scm
+++ b/gnu/packages/web.scm
@@ -123,14 +123,14 @@ and its related documentation.")
(define-public nginx
(package
(name "nginx")
- (version "1.11.4")
+ (version "1.11.6")
(source (origin
(method url-fetch)
(uri (string-append "https://nginx.org/download/nginx-"
version ".tar.gz"))
(sha256
(base32
- "0fvb09ycxz3xnyynav6ybj6miwh9kv8jcb2vzrmvqhzn8cgiq8h6"))))
+ "1gc5phrzm2hbpvryaya6rlvasa00vjips4hv5q1rqbcfa6xsnlri"))))
(build-system gnu-build-system)
(inputs `(("pcre" ,pcre)
("openssl" ,openssl)
@@ -150,7 +150,6 @@ and its related documentation.")
(list (string-append "--prefix=" (assoc-ref outputs "out"))
"--with-http_ssl_module"
"--with-pcre-jit"
- "--with-ipv6"
"--with-debug"
;; Even when not cross-building, we pass the
;; --crossbuild option to avoid customizing for the
diff --git a/gnu/packages/wxwidgets.scm b/gnu/packages/wxwidgets.scm
index 31da2a9eed..b72567f259 100644
--- a/gnu/packages/wxwidgets.scm
+++ b/gnu/packages/wxwidgets.scm
@@ -1,6 +1,8 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2016 Theodoros Foradis <theodoros.for@openmailbox.org>
+;;; Copyright © 2016 Danny Milosavljevic <dannym@scratchpost.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -22,6 +24,7 @@
#:use-module (guix download)
#:use-module ((guix licenses) #:prefix l:)
#:use-module (guix build-system glib-or-gtk)
+ #:use-module (guix build-system python)
#:use-module (guix build utils)
#:use-module (gnu packages)
#:use-module (gnu packages compression)
@@ -31,6 +34,7 @@
#:use-module (gnu packages gtk)
#:use-module (gnu packages image)
#:use-module (gnu packages pkg-config)
+ #:use-module (gnu packages python)
#:use-module (gnu packages sdl)
#:use-module (gnu packages webkit)
#:use-module (gnu packages xorg))
@@ -109,3 +113,80 @@ and many other languages.")
(assoc-ref %outputs "out") "/lib"))
;; No 'check' target.
#:tests? #f))))
+
+(define-public wxwidgets-gtk2
+ (package (inherit wxwidgets)
+ (inputs `(("gtk+" ,gtk+-2)
+ ,@(alist-delete
+ "gtk+"
+ (package-inputs wxwidgets))))
+ (name "wxwidgets-gtk2")))
+
+(define-public python2-wxpython
+ (package
+ (name "python2-wxpython")
+ (version "3.0.2.0")
+ (source
+ (origin
+ (method url-fetch)
+ (uri (string-append "mirror://sourceforge/wxpython/wxPython/"
+ version "/wxPython-src-" version ".tar.bz2"))
+ (sha256
+ (base32
+ "0qfzx3sqx4mwxv99sfybhsij4b5pc03ricl73h4vhkzazgjjjhfm"))
+ (modules '((guix build utils)))
+ (snippet
+ '(begin
+ (lambda (folder)
+ (delete-file-recursively (string-append "src/" folder))
+ '("expat" "jpeg" "png" "tiff" "zlib" "msw" "osx" "msdos"))
+ (substitute* '("wxPython/setup.py")
+ ;; setup.py tries to keep its own license the same as wxwidget's
+ ;; license (which it expects under $WXWIN/docs).
+ (("'preamble.txt', 'licence.txt', 'licendoc.txt', 'lgpl.txt'")
+ ""))))))
+ (build-system python-build-system)
+ (arguments
+ `(#:python ,python-2
+ #:tests? #f ; tests fail
+ #:configure-flags (list "WXPORT=gtk2"
+ "UNICODE=1")
+ #:phases
+ (modify-phases %standard-phases
+ (add-before 'build 'chdir
+ (lambda _
+ (chdir "wxPython")
+ #t))
+ (add-after 'chdir 'set-wx-out-dir
+ (lambda* (#:key outputs #:allow-other-keys)
+ ;; By default, install phase tries to copy the wxPython headers in
+ ;; gnu/store/...-wxwidgets-3.0.2 , which it can't, so they are
+ ;; redirected to the output directory by setting WXPREFIX.
+ (substitute* "config.py"
+ (("= getWxConfigValue\\('--prefix'\\)")
+ (string-append "= '" (assoc-ref outputs "out") "'")))
+ (substitute* "wx/build/config.py"
+ (("= getWxConfigValue\\('--prefix'\\)")
+ (string-append "= '" (assoc-ref outputs "out") "'")))
+ #t))
+ (add-after 'set-wx-out-dir 'setenv
+ (lambda* (#:key inputs outputs #:allow-other-keys)
+ (setenv "WXWIN" (assoc-ref inputs "wxwidgets"))
+ (use-modules (ice-9 popen) (ice-9 rdelim))
+ (let ((port (open-pipe* OPEN_READ
+ (string-append (assoc-ref inputs "wxwidgets")
+ "/bin/wx-config") "--cppflags")))
+ (setenv "CPPFLAGS" (read-string port))
+ (close-pipe port))
+ #t)))))
+ (native-inputs
+ `(("mesa" ,mesa) ; for glcanvas
+ ("pkg-config" ,pkg-config)
+ ("python2-setuptools" ,python2-setuptools)))
+ (inputs
+ `(("gtk+" ,gtk+-2) ; for wxPython/src/helpers.cpp
+ ("wxwidgets" ,wxwidgets-gtk2)))
+ (synopsis "Python 2 Bindings for wxWidgets")
+ (description "@code{wxpython} provides Python 2 bindings for wxWidgets.")
+ (home-page "http://wxpython.org/")
+ (license (package-license wxwidgets))))
diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm
new file mode 100644
index 0000000000..9f28aabc96
--- /dev/null
+++ b/gnu/services/configuration.scm
@@ -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))))
diff --git a/gnu/services/cups.scm b/gnu/services/cups.scm
index 7542ee26c0..391046a75f 100644
--- a/gnu/services/cups.scm
+++ b/gnu/services/cups.scm
@@ -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))
diff --git a/gnu/services/dbus.scm b/gnu/services/dbus.scm
index 876f56d45f..26390a4acd 100644
--- a/gnu/services/dbus.scm
+++ b/gnu/services/dbus.scm
@@ -21,7 +21,9 @@
#:use-module (gnu services)
#:use-module (gnu services shepherd)
#:use-module (gnu system shadow)
+ #:use-module (gnu system pam)
#:use-module ((gnu packages glib) #:select (dbus))
+ #:use-module (gnu packages polkit)
#:use-module (gnu packages admin)
#:use-module (guix gexp)
#:use-module (guix records)
@@ -30,7 +32,10 @@
#:export (dbus-configuration
dbus-configuration?
dbus-root-service-type
- dbus-service))
+ dbus-service
+
+ polkit-service-type
+ polkit-service))
;;;
;;; D-Bus.
@@ -218,4 +223,91 @@ and policy files. For example, to allow avahi-daemon to use the system bus,
(dbus-configuration (dbus dbus)
(services services))))
+
+;;;
+;;; Polkit privilege management service.
+;;;
+
+(define-record-type* <polkit-configuration>
+ polkit-configuration make-polkit-configuration
+ polkit-configuration?
+ (polkit polkit-configuration-polkit ;<package>
+ (default polkit))
+ (actions polkit-configuration-actions ;list of <package>
+ (default '())))
+
+(define %polkit-accounts
+ (list (user-group (name "polkitd") (system? #t))
+ (user-account
+ (name "polkitd")
+ (group "polkitd")
+ (system? #t)
+ (comment "Polkit daemon user")
+ (home-directory "/var/empty")
+ (shell "/run/current-system/profile/sbin/nologin"))))
+
+(define %polkit-pam-services
+ (list (unix-pam-service "polkit-1")))
+
+(define (polkit-directory packages)
+ "Return a directory containing an @file{actions} and possibly a
+@file{rules.d} sub-directory, for use as @file{/etc/polkit-1}."
+ (with-imported-modules '((guix build union))
+ (computed-file "etc-polkit-1"
+ #~(begin
+ (use-modules (guix build union) (srfi srfi-26))
+
+ (union-build #$output
+ (map (cut string-append <>
+ "/share/polkit-1")
+ (list #$@packages)))))))
+
+(define polkit-etc-files
+ (match-lambda
+ (($ <polkit-configuration> polkit packages)
+ `(("polkit-1" ,(polkit-directory (cons polkit packages)))))))
+
+(define polkit-setuid-programs
+ (match-lambda
+ (($ <polkit-configuration> polkit)
+ (list (file-append polkit "/lib/polkit-1/polkit-agent-helper-1")
+ (file-append polkit "/bin/pkexec")))))
+
+(define polkit-service-type
+ (service-type (name 'polkit)
+ (extensions
+ (list (service-extension account-service-type
+ (const %polkit-accounts))
+ (service-extension pam-root-service-type
+ (const %polkit-pam-services))
+ (service-extension dbus-root-service-type
+ (compose
+ list
+ polkit-configuration-polkit))
+ (service-extension etc-service-type
+ polkit-etc-files)
+ (service-extension setuid-program-service-type
+ polkit-setuid-programs)))
+
+ ;; Extensions are lists of packages that provide polkit rules
+ ;; or actions under share/polkit-1/{actions,rules.d}.
+ (compose concatenate)
+ (extend (lambda (config actions)
+ (polkit-configuration
+ (inherit config)
+ (actions
+ (append (polkit-configuration-actions config)
+ actions)))))))
+
+(define* (polkit-service #:key (polkit polkit))
+ "Return a service that runs the
+@uref{http://www.freedesktop.org/wiki/Software/polkit/, Polkit privilege
+management service}, which allows system administrators to grant access to
+privileged operations in a structured way. By querying the Polkit service, a
+privileged system component can know when it should grant additional
+capabilities to ordinary users. For example, an ordinary user can be granted
+the capability to suspend the system if the user is logged in locally."
+ (service polkit-service-type
+ (polkit-configuration (polkit polkit))))
+
;;; dbus.scm ends here
diff --git a/gnu/services/desktop.scm b/gnu/services/desktop.scm
index dfd1ea6e92..7555780ade 100644
--- a/gnu/services/desktop.scm
+++ b/gnu/services/desktop.scm
@@ -37,7 +37,6 @@
#:use-module (gnu packages gnome)
#:use-module (gnu packages xfce)
#:use-module (gnu packages avahi)
- #:use-module (gnu packages polkit)
#:use-module (gnu packages xdisorg)
#:use-module (gnu packages suckless)
#:use-module (gnu packages linux)
@@ -68,11 +67,6 @@
bluetooth-service
- polkit-configuration
- polkit-configuration?
- polkit-service
- polkit-service-type
-
elogind-configuration
elogind-configuration?
elogind-service
@@ -415,93 +409,6 @@ Users need to be in the @code{lp} group to access the D-Bus service.
;;;
-;;; Polkit privilege management service.
-;;;
-
-(define-record-type* <polkit-configuration>
- polkit-configuration make-polkit-configuration
- polkit-configuration?
- (polkit polkit-configuration-polkit ;<package>
- (default polkit))
- (actions polkit-configuration-actions ;list of <package>
- (default '())))
-
-(define %polkit-accounts
- (list (user-group (name "polkitd") (system? #t))
- (user-account
- (name "polkitd")
- (group "polkitd")
- (system? #t)
- (comment "Polkit daemon user")
- (home-directory "/var/empty")
- (shell "/run/current-system/profile/sbin/nologin"))))
-
-(define %polkit-pam-services
- (list (unix-pam-service "polkit-1")))
-
-(define (polkit-directory packages)
- "Return a directory containing an @file{actions} and possibly a
-@file{rules.d} sub-directory, for use as @file{/etc/polkit-1}."
- (with-imported-modules '((guix build union))
- (computed-file "etc-polkit-1"
- #~(begin
- (use-modules (guix build union) (srfi srfi-26))
-
- (union-build #$output
- (map (cut string-append <>
- "/share/polkit-1")
- (list #$@packages)))))))
-
-(define polkit-etc-files
- (match-lambda
- (($ <polkit-configuration> polkit packages)
- `(("polkit-1" ,(polkit-directory (cons polkit packages)))))))
-
-(define polkit-setuid-programs
- (match-lambda
- (($ <polkit-configuration> polkit)
- (list (file-append polkit "/lib/polkit-1/polkit-agent-helper-1")
- (file-append polkit "/bin/pkexec")))))
-
-(define polkit-service-type
- (service-type (name 'polkit)
- (extensions
- (list (service-extension account-service-type
- (const %polkit-accounts))
- (service-extension pam-root-service-type
- (const %polkit-pam-services))
- (service-extension dbus-root-service-type
- (compose
- list
- polkit-configuration-polkit))
- (service-extension etc-service-type
- polkit-etc-files)
- (service-extension setuid-program-service-type
- polkit-setuid-programs)))
-
- ;; Extensions are lists of packages that provide polkit rules
- ;; or actions under share/polkit-1/{actions,rules.d}.
- (compose concatenate)
- (extend (lambda (config actions)
- (polkit-configuration
- (inherit config)
- (actions
- (append (polkit-configuration-actions config)
- actions)))))))
-
-(define* (polkit-service #:key (polkit polkit))
- "Return a service that runs the
-@uref{http://www.freedesktop.org/wiki/Software/polkit/, Polkit privilege
-management service}, which allows system administrators to grant access to
-privileged operations in a structured way. By querying the Polkit service, a
-privileged system component can know when it should grant additional
-capabilities to ordinary users. For example, an ordinary user can be granted
-the capability to suspend the system if the user is logged in locally."
- (service polkit-service-type
- (polkit-configuration (polkit polkit))))
-
-
-;;;
;;; Colord D-Bus service.
;;;
diff --git a/gnu/services/kerberos.scm b/gnu/services/kerberos.scm
index 144c71bba0..a56f63082c 100644
--- a/gnu/services/kerberos.scm
+++ b/gnu/services/kerberos.scm
@@ -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
diff --git a/gnu/services/mail.scm b/gnu/services/mail.scm
index cb0f119f43..c1381405d8 100644
--- a/gnu/services/mail.scm
+++ b/gnu/services/mail.scm
@@ -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)))))
diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm
index 5a83240d77..bbb9053008 100644
--- a/gnu/services/networking.scm
+++ b/gnu/services/networking.scm
@@ -682,7 +682,7 @@ and @command{wicd-curses} user interfaces."
(list (shepherd-service
(documentation "Run the NetworkManager.")
(provision '(networking))
- (requirement '(user-processes dbus-system loopback))
+ (requirement '(user-processes dbus-system wpa-supplicant loopback))
(start #~(make-forkexec-constructor
(list (string-append #$network-manager
"/sbin/NetworkManager")
@@ -695,6 +695,7 @@ and @command{wicd-curses} user interfaces."
(list (service-extension shepherd-root-service-type
network-manager-shepherd-service)
(service-extension dbus-root-service-type list)
+ (service-extension polkit-service-type list)
(service-extension activation-service-type
(const %network-manager-activation))
;; Add network-manager to the system profile.
diff --git a/gnu/system/examples/desktop.tmpl b/gnu/system/examples/desktop.tmpl
index 2fcf90f8b1..82687e740b 100644
--- a/gnu/system/examples/desktop.tmpl
+++ b/gnu/system/examples/desktop.tmpl
@@ -1,5 +1,6 @@
;; This is an operating system configuration template
-;; for a "desktop" setup with GNOME and Xfce.
+;; for a "desktop" setup with GNOME and Xfce where the
+;; root partition is encrypted with LUKS.
(use-modules (gnu) (gnu system nss))
(use-service-modules desktop)
@@ -13,11 +14,21 @@
;; Assuming /dev/sdX is the target hard disk, and "my-root"
;; is the label of the target root file system.
(bootloader (grub-configuration (device "/dev/sdX")))
+
+ ;; Specify a mapped device for the encrypted root partition.
+ ;; The UUID is that returned by 'cryptsetup luksUUID'.
+ (mapped-devices
+ (list (mapped-device
+ (source (uuid "12345678-1234-1234-1234-123456789abc"))
+ (target "the-root-device")
+ (type luks-device-mapping))))
+
(file-systems (cons (file-system
(device "my-root")
(title 'label)
(mount-point "/")
- (type "ext4"))
+ (type "ext4")
+ (dependencies mapped-devices))
%base-file-systems))
(users (cons (user-account
diff --git a/gnu/system/mapped-devices.scm b/gnu/system/mapped-devices.scm
index e44f2693a7..8ab861bf73 100644
--- a/gnu/system/mapped-devices.scm
+++ b/gnu/system/mapped-devices.scm
@@ -23,7 +23,7 @@
#:use-module (guix modules)
#:use-module (gnu services)
#:use-module (gnu services shepherd)
- #:autoload (gnu packages cryptsetup) (cryptsetup)
+ #:autoload (gnu packages cryptsetup) (cryptsetup-static)
#:autoload (gnu packages linux) (mdadm-static)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
@@ -104,7 +104,9 @@
((gnu build file-systems)
#:select (find-partition-by-luks-uuid)))
- (zero? (system* (string-append #$cryptsetup "/sbin/cryptsetup")
+ ;; Use 'cryptsetup-static', not 'cryptsetup', to avoid pulling the
+ ;; whole world inside the initrd (for when we're in an initrd).
+ (zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
"open" "--type" "luks"
;; Note: We cannot use the "UUID=source" syntax here
@@ -120,7 +122,7 @@
(define (close-luks-device source target)
"Return a gexp that closes TARGET, a LUKS device."
- #~(zero? (system* (string-append #$cryptsetup "/sbin/cryptsetup")
+ #~(zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
"close" #$target)))
(define luks-device-mapping
diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm
index 9a265309c0..6370d6951b 100644
--- a/gnu/tests/base.scm
+++ b/gnu/tests/base.scm
@@ -31,6 +31,8 @@
#:use-module (gnu services mcron)
#:use-module (gnu services shepherd)
#:use-module (gnu services networking)
+ #:use-module (gnu packages imagemagick)
+ #:use-module (gnu packages ocr)
#:use-module (guix gexp)
#:use-module (guix store)
#:use-module (guix monads)
@@ -65,10 +67,16 @@
%base-user-accounts))))
-(define* (run-basic-test os command #:optional (name "basic"))
+(define* (run-basic-test os command #:optional (name "basic")
+ #:key initialization)
"Return a derivation called NAME that tests basic features of the OS started
using COMMAND, a gexp that evaluates to a list of strings. Compare some
-properties of running system to what's declared in OS, an <operating-system>."
+properties of running system to what's declared in OS, an <operating-system>.
+
+When INITIALIZATION is true, it must be a one-argument procedure that is
+passed a gexp denoting the marionette, and it must return gexp that is
+inserted before the first test. This is used to introduce an extra
+initialization step, such as entering a LUKS passphrase."
(define test
(with-imported-modules '((gnu build marionette))
#~(begin
@@ -86,6 +94,9 @@ properties of running system to what's declared in OS, an <operating-system>."
(test-begin "basic")
+ #$(and initialization
+ (initialization #~marionette))
+
(test-assert "uname"
(match (marionette-eval '(uname) marionette)
(#("Linux" host-name version _ architecture)
@@ -188,14 +199,8 @@ info --version")
(test-equal "locale"
"en_US.utf8"
- (marionette-eval '(begin
- ;; XXX: This 'setenv' call wouldn't be needed
- ;; but our glibc@2.23 currently ignores
- ;; /run/current-system/locale.
- (setenv "GUIX_LOCPATH"
- "/run/current-system/locale")
- (let ((before (setlocale LC_ALL "en_US.utf8")))
- (setlocale LC_ALL before)))
+ (marionette-eval '(let ((before (setlocale LC_ALL "en_US.utf8")))
+ (setlocale LC_ALL before))
marionette))
(test-assert "/run/current-system is a GC root"
@@ -241,6 +246,20 @@ info --version")
marionette)
(file-exists? "tty1.ppm")))
+ (test-assert "screen text"
+ (let ((text (marionette-screen-text marionette
+ #:ocrad
+ #$(file-append ocrad
+ "/bin/ocrad"))))
+ ;; Check whether the welcome message and shell prompt are
+ ;; displayed. Note: OCR confuses "y" and "V" for instance, so
+ ;; we cannot reliably match the whole text.
+ (and (string-contains text "This is the GNU")
+ (string-contains text
+ (string-append
+ "root@"
+ #$(operating-system-host-name os))))))
+
(test-end)
(exit (= (test-runner-fail-count (test-runner-current)) 0)))))
diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm
index 98f8649af8..ecf1ac1923 100644
--- a/gnu/tests/install.scm
+++ b/gnu/tests/install.scm
@@ -24,6 +24,7 @@
#:use-module (gnu system install)
#:use-module (gnu system vm)
#:use-module ((gnu build vm) #:select (qemu-command))
+ #:use-module (gnu packages ocr)
#:use-module (gnu packages qemu)
#:use-module (gnu packages package-management)
#:use-module (guix store)
@@ -398,17 +399,20 @@ by 'mdadm'.")
(locale "en_US.UTF-8")
(bootloader (grub-configuration (device "/dev/vdb")))
- (kernel-arguments '("console=ttyS0"))
+
+ ;; Note: Do not pass "console=ttyS0" so we can use our passphrase prompt
+ ;; detection logic in 'enter-luks-passphrase'.
+
+ (mapped-devices (list (mapped-device
+ (source (uuid "12345678-1234-1234-1234-123456789abc"))
+ (target "the-root-device")
+ (type luks-device-mapping))))
(file-systems (cons (file-system
(device "/dev/mapper/the-root-device")
(title 'device)
(mount-point "/")
(type "ext4"))
%base-file-systems))
- (mapped-devices (list (mapped-device
- (source "REPLACE-WITH-LUKS-UUID")
- (target "the-root-device")
- (type luks-device-mapping))))
(users (cons (user-account
(name "charlie")
(group "users")
@@ -435,7 +439,8 @@ parted --script /dev/vdb mklabel gpt \\
mkpart primary ext2 3M 1G \\
set 1 boot on \\
set 1 bios_grub on
-echo -n thepassphrase | cryptsetup luksFormat -q /dev/vdb2 -
+echo -n thepassphrase | \\
+ cryptsetup luksFormat --uuid=12345678-1234-1234-1234-123456789abc -q /dev/vdb2 -
echo -n thepassphrase | \\
cryptsetup open --type luks --key-file - /dev/vdb2 the-root-device
mkfs.ext4 -L my-root /dev/mapper/the-root-device
@@ -443,15 +448,53 @@ mount LABEL=my-root /mnt
herd start cow-store /mnt
mkdir /mnt/etc
cp /etc/target-config.scm /mnt/etc/config.scm
-cat /mnt/etc/config
-luks_uuid=`cryptsetup luksUUID /dev/vdb2`
-sed -i /mnt/etc/config.scm \\
- -e \"s/\\\"REPLACE-WITH-LUKS-UUID\\\"/(uuid \\\"$luks_uuid\\\")/g\"
guix system build /mnt/etc/config.scm
guix system init /mnt/etc/config.scm /mnt --no-substitutes
sync
reboot\n")
+(define (enter-luks-passphrase marionette)
+ "Return a gexp to be inserted in the basic system test running on MARIONETTE
+to enter the LUKS passphrase."
+ (let ((ocrad (file-append ocrad "/bin/ocrad")))
+ #~(begin
+ (define (passphrase-prompt? text)
+ (string-contains (pk 'screen-text text) "Enter pass"))
+
+ (define (bios-boot-screen? text)
+ ;; Return true if TEXT corresponds to the boot screen, before GRUB's
+ ;; menu.
+ (string-prefix? "SeaBIOS" text))
+
+ (test-assert "enter LUKS passphrase for GRUB"
+ (begin
+ ;; At this point we have no choice but to use OCR to determine
+ ;; when the passphrase should be entered.
+ (wait-for-screen-text #$marionette passphrase-prompt?
+ #:ocrad #$ocrad)
+ (marionette-type "thepassphrase\n" #$marionette)
+
+ ;; Now wait until we leave the boot screen. This is necessary so
+ ;; we can then be sure we match the "Enter passphrase" prompt from
+ ;; 'cryptsetup', in the initrd.
+ (wait-for-screen-text #$marionette (negate bios-boot-screen?)
+ #:ocrad #$ocrad
+ #:timeout 20)))
+
+ (test-assert "enter LUKS passphrase for the initrd"
+ (begin
+ ;; XXX: Here we use OCR as well but we could instead use QEMU
+ ;; '-serial stdio' and run it in an input pipe,
+ (wait-for-screen-text #$marionette passphrase-prompt?
+ #:ocrad #$ocrad
+ #:timeout 60)
+ (marionette-type "thepassphrase\n" #$marionette)
+
+ ;; Take a screenshot for debugging purposes.
+ (marionette-control (string-append "screendump " #$output
+ "/post-initrd-passphrase.ppm")
+ #$marionette))))))
+
(define %test-encrypted-os
(system-test
(name "encrypted-root-os")
@@ -465,6 +508,7 @@ build (current-guix) and then store a couple of full system images.")
#:script
%encrypted-root-installation-script))
(command (qemu-command/writable-image image)))
- (run-basic-test %encrypted-root-os command "encrypted-root-os")))))
+ (run-basic-test %encrypted-root-os command "encrypted-root-os"
+ #:initialization enter-luks-passphrase)))))
;;; install.scm ends here
diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index 33d141e7ef..2e0268020c 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -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-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)))))))
-
-(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))))
-
- ;; 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))
-
- ;; XXX: Remove '-i' when %LSHG-COMMAND really is lshg.
- "-i" (build-machine-private-key machine)
-
- (append (build-machine-ssh-options machine)
- (list (build-machine-name machine))
- (if quote?
- (map shell-quote command)
- command)))))
+(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))))
+
+ (match (string-tokenize host-key)
+ ((type key _)
+ (values (type->symbol type) key))
+ ((type key)
+ (values (type->symbol type) key))))
+
+(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))))))))
+
+(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)
+
+ ;; We need lightweight compression when
+ ;; exchanging full archives.
+ #:compression "zlib"
+ #:compression-level 3)))
+ (connect! session)
+
+ ;; 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))
-
- ;; Use exit code 100 for a permanent build failure. The daemon
- ;; interprets other non-zero codes as transient build failures.
- (primitive-exit 100))))))
-
-(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)))
+ (define session
+ (open-ssh-session machine))
+
+ (define store
+ (connect-to-remote-daemon session
+ (build-machine-daemon-socket machine)))
+
+ (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 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"))
-
- ;; Wait for the 'lsh' process to complete.
- (zero? (close-pipe pipe))))))
-
-(define (retrieve-files files machine)
- "Retrieve FILES from MACHINE's store, and import them."
- (define host
- (build-machine-name machine))
-
- (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)
-
- ;; 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)))
-
- ;; Wait for the 'lsh' process to complete.
- (zero? (close-pipe pipe)))))))
+ ;; 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))
+
+ (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))
+
+ (export-paths store missing port)
+
+ ;; 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)
+
+ ;; Wait for completion of the remote process.
+ (let ((result (zero? (channel-get-exit-status port))))
+ (close-port port)
+ result))))
+
+(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)
+
+ ;; 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,11 @@ 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)))
+ (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
@@ -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
diff --git a/guix/store.scm b/guix/store.scm
index 7f54b87db1..689a94c636 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -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."
diff --git a/m4/guix.m4 b/m4/guix.m4
index 6d8ec2e4e0..6630598416 100644
--- a/m4/guix.m4
+++ b/m4/guix.m4
@@ -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],
diff --git a/nix/local.mk b/nix/local.mk
index 86ef769549..79667ed49e 100644
--- a/nix/local.mk
+++ b/nix/local.mk
@@ -183,26 +183,26 @@ endif BUILD_DAEMON_OFFLOAD
nodist_libexec_SCRIPTS = \
%D%/scripts/guix-authenticate
-# The '.service' file for systemd.
+# The '.service' files for systemd.
systemdservicedir = $(libdir)/systemd/system
-nodist_systemdservice_DATA = etc/guix-daemon.service
+nodist_systemdservice_DATA = etc/guix-daemon.service etc/guix-publish.service
-etc/guix-daemon.service: etc/guix-daemon.service.in \
+etc/guix-%.service: etc/guix-%.service.in \
$(top_builddir)/config.status
$(AM_V_GEN)$(MKDIR_P) "`dirname $@`"; \
$(SED) -e 's|@''bindir''@|$(bindir)|' < \
- "$(srcdir)/etc/guix-daemon.service.in" > "$@.tmp"; \
+ "$(srcdir)/$<" > "$@.tmp"; \
mv "$@.tmp" "$@"
-# The '.conf' job for Upstart.
+# The '.conf' jobs for Upstart.
upstartjobdir = $(libdir)/upstart/system
-nodist_upstartjob_DATA = etc/guix-daemon.conf
+nodist_upstartjob_DATA = etc/guix-daemon.conf etc/guix-publish.conf
-etc/guix-daemon.conf: etc/guix-daemon.conf.in \
+etc/guix-%.conf: etc/guix-%.conf.in \
$(top_builddir)/config.status
$(AM_V_GEN)$(MKDIR_P) "`dirname $@`"; \
$(SED) -e 's|@''bindir''@|$(bindir)|' < \
- "$(srcdir)/etc/guix-daemon.conf.in" > "$@.tmp"; \
+ "$(srcdir)/$<" > "$@.tmp"; \
mv "$@.tmp" "$@"
EXTRA_DIST += \