Merge branch 'master' into core-updates

.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

.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>

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
 

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

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
 
@@ -566,6 +566,12 @@ allow you to use the @command{guix import pypi} command (@pxref{Invoking
 guix import}).  It is of
 interest primarily for developers and not for casual users.
 
+@item
+@c Note: We need at least 0.10.2 for 'channel-send-eof'.
+Support for build offloading (@pxref{Daemon Offload Setup}) depends on
+@uref{https://github.com/artyom-poptsov/guile-ssh, Guile-SSH},
+version 0.10.2 or later.
+
 @item
 When @url{http://zlib.net, zlib} is available, @command{guix publish}
 can compress build byproducts (@pxref{Invoking guix publish}).
@@ -814,9 +820,11 @@ available on the system---making it much harder to view them as
 
 @cindex offloading
 @cindex build hook
-When desired, the build daemon can @dfn{offload}
-derivation builds to other machines
-running Guix, using the @code{offload} @dfn{build hook}.  When that
+When desired, the build daemon can @dfn{offload} derivation builds to
+other machines running Guix, using the @code{offload} @dfn{build
+hook}@footnote{This feature is available only when
+@uref{https://github.com/artyom-poptsov/guile-ssh, Guile-SSH} is
+present.}.  When that
 feature is enabled, a list of user-specified build machines is read from
 @file{/etc/guix/machines.scm}; every time a build is requested, for
 instance via @code{guix build}, the daemon attempts to offload it to one
@@ -832,16 +840,18 @@ The @file{/etc/guix/machines.scm} file typically looks like this:
 (list (build-machine
         (name "eightysix.example.org")
         (system "x86_64-linux")
+        (host-key "ssh-ed25519 AAAAC3Nza@dots{}")
         (user "bob")
-        (speed 2.))    ; incredibly fast!
+        (speed 2.))     ;incredibly fast!
 
       (build-machine
         (name "meeps.example.org")
         (system "mips64el-linux")
+        (host-key "ssh-rsa AAAAB3Nza@dots{}")
         (user "alice")
         (private-key
          (string-append (getenv "HOME")
-                        "/.lsh/identity-for-guix"))))
+                        "/.ssh/identity-for-guix"))))
 @end example
 
 @noindent
@@ -875,31 +885,54 @@ The user account to use when connecting to the remote machine over SSH.
 Note that the SSH key pair must @emph{not} be passphrase-protected, to
 allow non-interactive logins.
 
+@item host-key
+This must be the machine's SSH @dfn{public host key} in OpenSSH format.
+This is used to authenticate the machine when we connect to it.  It is a
+long string that looks like this:
+
+@example
+ssh-ed25519 AAAAC3NzaC@dots{}mde+UhL hint@@example.org
+@end example
+
+If the machine is running the OpenSSH daemon, @command{sshd}, the host
+key can be found in a file such as
+@file{/etc/ssh/ssh_host_ed25519_key.pub}.
+
+If the machine is running the SSH daemon of GNU@tie{}lsh,
+@command{lshd}, the host key is in @file{/etc/lsh/host-key.pub} or a
+similar file.  It can be converted to the OpenSSH format using
+@command{lsh-export-key} (@pxref{Converting keys,,, lsh, LSH Manual}):
+
+@example
+$ lsh-export-key --openssh < /etc/lsh/host-key.pub 
+ssh-rsa AAAAB3NzaC1yc2EAAAAEOp8FoQAAAQEAs1eB46LV@dots{}
+@end example
+
 @end table
 
 A number of optional fields may be specified:
 
-@table @code
+@table @asis
 
-@item port
-Port number of SSH server on the machine (default: 22).
+@item @code{port} (default: @code{22})
+Port number of SSH server on the machine.
 
-@item private-key
-The SSH private key file to use when connecting to the machine.
+@item @code{private-key} (default: @file{~/.ssh/id_rsa})
+The SSH private key file to use when connecting to the machine, in
+OpenSSH format.
 
-Currently offloading uses GNU@tie{}lsh as its SSH client
-(@pxref{Invoking lsh,,, GNU lsh Manual}).  Thus, the key file here must
-be an lsh key file.  This may change in the future, though.
+@item @code{daemon-socket} (default: @code{"/var/guix/daemon-socket/socket"})
+File name of the Unix-domain socket @command{guix-daemon} is listening
+to on that machine.
 
-@item parallel-builds
-The number of builds that may run in parallel on the machine (1 by
-default.)
+@item @code{parallel-builds} (default: @code{1})
+The number of builds that may run in parallel on the machine.
 
-@item speed
+@item @code{speed} (default: @code{1.0})
 A ``relative speed factor''.  The offload scheduler will tend to prefer
 machines with a higher speed factor.
 
-@item features
+@item @code{features} (default: @code{'()})
 A list of strings denoting specific features supported by the machine.
 An example is @code{"kvm"} for machines that have the KVM Linux modules
 and corresponding hardware support.  Derivations can request features by
@@ -915,7 +948,7 @@ machines, since offloading works by invoking the @code{guix archive} and
 this is the case by running:
 
 @example
-lsh build-machine guile -c "'(use-modules (guix config))'"
+ssh build-machine guile -c "'(use-modules (guix config))'"
 @end example
 
 There is one last thing to do once @file{machines.scm} is in place.  As
@@ -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
-
-In addition to e2fsprogs, the suite of tools to manipulate
-ext2/ext3/ext4 file systems, the installation image includes
-Cryptsetup/LUKS for disk encryption.
-
-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):
+@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:
 
 @example
-mount /dev/sda1 /mnt
+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 @code{my-root} is the label of the
+root partition):
+
+@example
+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.

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

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

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")

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")

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			\

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")))

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

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

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)

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

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

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")

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"))))))

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+))))

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"))))

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")

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

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!)

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 _

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

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

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
+

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
+

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
+

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
+

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

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")

gnu/packages/psyc.scm

@@ -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))))

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

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 _

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

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))))

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"))))

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)

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"

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

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))))

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))))

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))

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

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
@@ -413,93 +407,6 @@ Users need to be in the @code{lp} group to access the D-Bus service.
 "
   (service bluetooth-service-type bluez))
 
-
-;;;
-;;; 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.

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

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)))))

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.

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

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

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)))))
 

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

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 (host-key->type+key host-key)
+  "Destructure HOST-KEY, an OpenSSH host key string, and return two values:
+its key type as a symbol, and the actual base64-encoded string."
+  (define (type->symbol type)
+    (and (string-prefix? "ssh-" type)
+         (string->symbol (string-drop type 4))))
 
-(define-syntax with-error-to-port
-  (syntax-rules ()
-    ((_ port exp0 exp ...)
-     (let ((new port)
-           (old (current-error-port)))
-       (dynamic-wind
-         (lambda ()
-           (set-current-error-port new))
-         (lambda ()
-           exp0 exp ...)
-         (lambda ()
-           (set-current-error-port old)))))))
+  (match (string-tokenize host-key)
+    ((type key _)
+     (values (type->symbol type) key))
+    ((type key)
+     (values (type->symbol type) key))))
 
-(define* (remote-pipe machine mode command
-                      #:key (error-port (current-error-port)) (quote? #t))
-  "Run COMMAND (a string list) on MACHINE, assuming an lsh gateway has been
-set up.  When QUOTE? is true, perform shell-quotation of all the elements of
-COMMAND.  Return either a pipe opened with MODE, or #f if the lsh client could
-not be started."
-  (define (shell-quote str)
-    ;; Sort-of shell-quote STR so it can be passed as an argument to the
-    ;; shell.
-    (with-output-to-string
-      (lambda ()
-        (write str))))
+(define (private-key-from-file* file)
+  "Like 'private-key-from-file', but raise an error that 'with-error-handling'
+can interpret meaningfully."
+  (catch 'guile-ssh-error
+    (lambda ()
+      (private-key-from-file file))
+    (lambda (key proc str . rest)
+      (raise (condition
+              (&message (message (format #f (_ "failed to load SSH \
+private key from '~a': ~a")
+                                         file str))))))))
 
-  ;; Let the child inherit ERROR-PORT.
-  (with-error-to-port error-port
-    (apply open-pipe* mode %lshg-command
-           "-l" (build-machine-user machine)
-           "-p" (number->string (build-machine-port machine))
+(define (open-ssh-session machine)
+  "Open an SSH session for MACHINE and return it.  Throw an error on failure."
+  (let ((private (private-key-from-file* (build-machine-private-key machine)))
+        (public  (public-key-from-file
+                  (string-append (build-machine-private-key machine)
+                                 ".pub")))
+        (session (make-session #:user (build-machine-user machine)
+                               #:host (build-machine-name machine)
+                               #:port (build-machine-port machine)
+                               #:timeout 5        ;seconds
+                               ;; #:log-verbosity 'protocol
+                               #:identity (build-machine-private-key machine)
 
-           ;; XXX: Remove '-i' when %LSHG-COMMAND really is lshg.
-           "-i" (build-machine-private-key machine)
+                               ;; We need lightweight compression when
+                               ;; exchanging full archives.
+                               #:compression "zlib"
+                               #:compression-level 3)))
+    (connect! session)
 
-           (append (build-machine-ssh-options machine)
-                   (list (build-machine-name machine))
-                   (if quote?
-                       (map shell-quote command)
-                       command)))))
+    ;; Authenticate the server.  XXX: Guile-SSH 0.10.1 doesn't know about
+    ;; ed25519 keys and 'get-key-type' returns #f in that case.
+    (let-values (((server)   (get-server-public-key session))
+                 ((type key) (host-key->type+key
+                              (build-machine-host-key machine))))
+      (unless (and (or (not (get-key-type server))
+                       (eq? (get-key-type server) type))
+                   (string=? (public-key->string server) key))
+        ;; Key mismatch: something's wrong.  XXX: It could be that the server
+        ;; provided its Ed25519 key when we where expecting its RSA key.
+        (leave (_ "server at '~a' returned host key '~a' of type '~a' \
+instead of '~a' of type '~a'~%")
+               (build-machine-name machine)
+               (public-key->string server) (get-key-type server)
+               key type)))
+
+    (let ((auth (userauth-public-key! session private)))
+      (unless (eq? 'success auth)
+        (disconnect! session)
+        (leave (_ "SSH public key authentication failed for '~a': ~a~%")
+               (build-machine-name machine) (get-error session))))
+
+    session))
+
+(define* (connect-to-remote-daemon session
+                                   #:optional
+                                   (socket-name "/var/guix/daemon-socket/socket"))
+  "Connect to the remote build daemon listening on SOCKET-NAME over SESSION,
+an SSH session.  Return a <nix-server> object."
+  (define redirect
+    ;; Code run in SESSION to redirect the remote process' stdin/stdout to the
+    ;; daemon's socket, à la socat.  The SSH protocol supports forwarding to
+    ;; Unix-domain sockets but libssh doesn't have an API for that, hence this
+    ;; hack.
+    `(begin
+       (use-modules (ice-9 match) (rnrs io ports))
+
+       (let ((sock   (socket AF_UNIX SOCK_STREAM 0))
+             (stdin  (current-input-port))
+             (stdout (current-output-port)))
+         (setvbuf stdin _IONBF)
+         (setvbuf stdout _IONBF)
+         (connect sock AF_UNIX ,socket-name)
+
+         (let loop ()
+           (match (select (list stdin sock) '() (list stdin stdout sock))
+             ((reads writes ())
+              (when (memq stdin reads)
+                (match (get-bytevector-some stdin)
+                  ((? eof-object?)
+                   (primitive-exit 0))
+                  (bv
+                   (put-bytevector sock bv))))
+              (when (memq sock reads)
+                (match (get-bytevector-some sock)
+                  ((? eof-object?)
+                   (primitive-exit 0))
+                  (bv
+                   (put-bytevector stdout bv))))
+              (loop))
+             (_
+              (primitive-exit 1)))))))
+
+  (let ((channel
+         (open-remote-pipe* session OPEN_BOTH
+                            ;; Sort-of shell-quote REDIRECT.
+                            "guile" "-c"
+                            (object->string
+                             (object->string redirect)))))
+    (open-connection #:port channel)))
 
 
 ;;;
@@ -299,113 +338,6 @@ hook."
     (set-port-revealed! port 1)
     port))
 
-(define %gc-root-file
-  ;; File name of the temporary GC root we install.
-  (format #f "offload-~a-~a" (gethostname) (getpid)))
-
-(define (register-gc-root file machine)
-  "Mark FILE, a store item, as a garbage collector root on MACHINE."
-  (define script
-    `(begin
-       (use-modules (guix config))
-
-       ;; Note: we can't use 'add-indirect-root' because dangling links under
-       ;; gcroots/auto are automatically deleted by the GC.  This strategy
-       ;; doesn't have this problem, but it requires write access to that
-       ;; directory.
-       (let ((root-directory (string-append %state-directory
-                                            "/gcroots/tmp")))
-         (catch 'system-error
-           (lambda ()
-             (mkdir root-directory))
-           (lambda args
-             (unless (= EEXIST (system-error-errno args))
-               (error "failed to create remote GC root directory"
-                      root-directory (system-error-errno args)))))
-
-         (catch 'system-error
-           (lambda ()
-             (symlink ,file
-                      (string-append root-directory "/" ,%gc-root-file)))
-           (lambda args
-             ;; If FILE already exists, we can assume that either it's a stale
-             ;; reference (which is fine), or another process is already
-             ;; building the derivation represented by FILE (which is fine
-             ;; too.)  Thus, do nothing in that case.
-             (unless (= EEXIST (system-error-errno args))
-               (apply throw args)))))))
-
-  (let ((pipe (remote-pipe machine OPEN_READ
-                           `("guile" "-c" ,(object->string script)))))
-    (read-string pipe)
-    (let ((status (close-pipe pipe)))
-      (unless (zero? status)
-        ;; Better be safe than sorry: if we ignore the error here, then FILE
-        ;; may be GC'd just before we start using it.
-        (leave (_ "failed to register GC root for '~a' on '~a' (status: ~a)~%")
-               file (build-machine-name machine) status)))))
-
-(define (remove-gc-roots machine)
-  "Remove from MACHINE the GC roots previously installed with
-'register-gc-root'."
-  (define script
-    `(begin
-       (use-modules (guix config) (ice-9 ftw)
-                    (srfi srfi-1) (srfi srfi-26))
-
-       (let ((root-directory (string-append %state-directory
-                                            "/gcroots/tmp")))
-         (false-if-exception
-          (delete-file
-           (string-append root-directory "/" ,%gc-root-file)))
-
-         ;; These ones were created with 'guix build -r' (there can be more
-         ;; than one in case of multiple-output derivations.)
-         (let ((roots (filter (cut string-prefix? ,%gc-root-file <>)
-                              (scandir "."))))
-           (for-each (lambda (file)
-                       (false-if-exception (delete-file file)))
-                     roots)))))
-
-  (let ((pipe (remote-pipe machine OPEN_READ
-                           `("guile" "-c" ,(object->string script)))))
-    (read-string pipe)
-    (close-pipe pipe)))
-
-(define* (offload drv machine
-                  #:key print-build-trace? (max-silent-time 3600)
-                  build-timeout (log-port (build-log-port)))
-  "Perform DRV on MACHINE, assuming DRV and its prerequisites are available
-there, and write the build log to LOG-PORT.  Return the exit status."
-  (format (current-error-port) "offloading '~a' to '~a'...~%"
-          (derivation-file-name drv) (build-machine-name machine))
-  (format (current-error-port) "@ build-remote ~a ~a~%"
-          (derivation-file-name drv) (build-machine-name machine))
-
-  ;; Normally DRV has already been protected from GC when it was transferred.
-  ;; The '-r' flag below prevents the build result from being GC'd.
-  (let ((pipe (remote-pipe machine OPEN_READ
-                           `("guix" "build"
-                             "-r" ,%gc-root-file
-                             ,(format #f "--max-silent-time=~a"
-                                      max-silent-time)
-                             ,@(if build-timeout
-                                   (list (format #f "--timeout=~a"
-                                                 build-timeout))
-                                   '())
-                             ,(derivation-file-name drv))
-
-                           ;; Since 'guix build' writes the build log to its
-                           ;; stderr, everything will go directly to LOG-PORT.
-                           #:error-port log-port)))
-    (let loop ((line (read-line pipe)))
-      (unless (eof-object? line)
-        (display line log-port)
-        (newline log-port)
-        (loop (read-line pipe))))
-
-    (close-pipe pipe)))
-
 (define* (transfer-and-offload drv machine
                                #:key
                                (inputs '())
@@ -416,120 +348,131 @@ there, and write the build log to LOG-PORT.  Return the exit status."
   "Offload DRV to MACHINE.  Prior to the actual offloading, transfer all of
 INPUTS to MACHINE; if building DRV succeeds, retrieve all of OUTPUTS from
 MACHINE."
-  (when (begin
-          (register-gc-root (derivation-file-name drv) machine)
-          (send-files (cons (derivation-file-name drv) inputs)
-                      machine))
-    (let ((status (offload drv machine
-                           #:print-build-trace? print-build-trace?
-                           #:max-silent-time max-silent-time
-                           #:build-timeout build-timeout)))
-      (if (zero? status)
-          (begin
-            (retrieve-files outputs machine)
-            (remove-gc-roots machine)
-            (format (current-error-port)
-                    "done with offloaded '~a'~%"
-                    (derivation-file-name drv)))
-          (begin
-            (remove-gc-roots machine)
-            (format (current-error-port)
-                    "derivation '~a' offloaded to '~a' failed \
-with exit code ~a~%"
-                    (derivation-file-name drv)
-                    (build-machine-name machine)
-                    (status:exit-val status))
+  (define session
+    (open-ssh-session machine))
 
-            ;; Use exit code 100 for a permanent build failure.  The daemon
-            ;; interprets other non-zero codes as transient build failures.
-            (primitive-exit 100))))))
+  (define store
+    (connect-to-remote-daemon session
+                              (build-machine-daemon-socket machine)))
 
-(define (send-files files machine)
-  "Send the subset of FILES that's missing to MACHINE's store.  Return #t on
-success, #f otherwise."
-  (define (missing-files files)
-    ;; Return the subset of FILES not already on MACHINE.
-    (let*-values (((files)
-                   (format #f "~{~a~%~}" files))
-                  ((missing pids)
-                   (filtered-port
-                    (append (list (which %lshg-command)
-                                  "-l" (build-machine-user machine)
-                                  "-p" (number->string
-                                        (build-machine-port machine))
-                                  "-i" (build-machine-private-key machine))
-                            (build-machine-ssh-options machine)
-                            (cons (build-machine-name machine)
-                                  '("guix" "archive" "--missing")))
-                    (open-input-string files)))
-                  ((result)
-                   (read-string missing)))
-      (for-each waitpid pids)
-      (string-tokenize result)))
+  (set-build-options store
+                     #:print-build-trace print-build-trace?
+                     #:max-silent-time max-silent-time
+                     #:timeout build-timeout)
 
+  ;; Protect DRV from garbage collection.
+  (add-temp-root store (derivation-file-name drv))
+
+  (send-files (cons (derivation-file-name drv) inputs)
+              store)
+  (format (current-error-port) "offloading '~a' to '~a'...~%"
+          (derivation-file-name drv) (build-machine-name machine))
+  (format (current-error-port) "@ build-remote ~a ~a~%"
+          (derivation-file-name drv) (build-machine-name machine))
+
+  (guard (c ((nix-protocol-error? c)
+             (format (current-error-port)
+                     (_ "derivation '~a' offloaded to '~a' failed: ~a~%")
+                     (derivation-file-name drv)
+                     (build-machine-name machine)
+                     (nix-protocol-error-message c))
+             ;; Use exit code 100 for a permanent build failure.  The daemon
+             ;; interprets other non-zero codes as transient build failures.
+             (primitive-exit 100)))
+    (build-derivations store (list drv)))
+
+  (retrieve-files outputs store)
+  (format (current-error-port) "done with offloaded '~a'~%"
+          (derivation-file-name drv)))
+
+(define (store-import-channel session)
+  "Return an output port to which archives to be exported to SESSION's store
+can be written."
+  ;; Using the 'import-paths' RPC on a remote store would be slow because it
+  ;; makes a round trip every time 32 KiB have been transferred.  This
+  ;; procedure instead opens a separate channel to use the remote
+  ;; 'import-paths' procedure, which consumes all the data in a single round
+  ;; trip.
+  (define import
+    `(begin
+       (use-modules (guix))
+
+       (with-store store
+         (setvbuf (current-input-port) _IONBF)
+         (import-paths store (current-input-port)))))
+
+  (open-remote-output-pipe session
+                           (string-join
+                            `("guile" "-c"
+                              ,(object->string
+                                (object->string import))))))
+
+(define (store-export-channel session files)
+  "Return an input port from which an export of FILES from SESSION's store can
+be read."
+  ;; Same as above: this is more efficient than calling 'export-paths' on a
+  ;; remote store.
+  (define export
+    `(begin
+       (use-modules (guix))
+
+       (with-store store
+         (setvbuf (current-output-port) _IONBF)
+         (export-paths store ',files (current-output-port)))))
+
+  (open-remote-input-pipe session
+                          (string-join
+                           `("guile" "-c"
+                             ,(object->string
+                               (object->string export))))))
+
+(define (send-files files remote)
+  "Send the subset of FILES that's missing to REMOTE, a remote store."
   (with-store store
-    (guard (c ((nix-protocol-error? c)
-               (warning (_ "failed to export files for '~a': ~s~%")
-                        (build-machine-name machine)
-                        c)
-               #f))
+    ;; Compute the subset of FILES missing on SESSION, and send them in
+    ;; topologically sorted order so that they can actually be imported.
+    (let* ((sorted  (topologically-sorted store files))
+           (session (channel-get-session (nix-server-socket remote)))
+           (node    (make-node session))
+           (missing (node-eval node
+                               `(begin
+                                  (use-modules (guix)
+                                               (srfi srfi-1) (srfi srfi-26))
 
-      ;; Compute the subset of FILES missing on MACHINE, and send them in
-      ;; topologically sorted order so that they can actually be imported.
-      ;;
-      ;; To reduce load on the machine that's offloading (since it's typically
-      ;; already quite busy, see hydra.gnu.org), compress with gzip rather
-      ;; than xz: For a compression ratio 2 times larger, it is 20 times
-      ;; faster.
-      (let* ((files (missing-files (topologically-sorted store files)))
-             (pipe  (remote-pipe machine OPEN_WRITE
-                                 '("gzip" "-dc" "|"
-                                   "guix" "archive" "--import")
-                                 #:quote? #f)))
-        (format #t (_ "sending ~a store files to '~a'...~%")
-                (length files) (build-machine-name machine))
-        (call-with-compressed-output-port 'gzip pipe
-          (lambda (compressed)
-            (catch 'system-error
-              (lambda ()
-                (export-paths store files compressed))
-              (lambda args
-                (warning (_ "failed while exporting files to '~a': ~a~%")
-                         (build-machine-name machine)
-                         (strerror (system-error-errno args))))))
-          #:options '("--fast"))
+                                  (with-store store
+                                    (remove (cut valid-path? store <>)
+                                            ',sorted)))))
+           (port    (store-import-channel session)))
+      (format #t (_ "sending ~a store files to '~a'...~%")
+              (length missing) (session-get session 'host))
 
-        ;; Wait for the 'lsh' process to complete.
-        (zero? (close-pipe pipe))))))
+      (export-paths store missing port)
 
-(define (retrieve-files files machine)
-  "Retrieve FILES from MACHINE's store, and import them."
-  (define host
-    (build-machine-name machine))
+      ;; Tell the remote process that we're done.  (In theory the
+      ;; end-of-archive mark of 'export-paths' would be enough, but in
+      ;; practice it's not.)
+      (channel-send-eof port)
 
-  (let ((pipe (remote-pipe machine OPEN_READ
-                           `("guix" "archive" "--export" ,@files
-                             "|" "xz" "-c")
-                           #:quote? #f)))
-    (and pipe
-         (with-store store
-           (guard (c ((nix-protocol-error? c)
-                      (warning (_ "failed to import files from '~a': ~s~%")
-                               host c)
-                      #f))
-             (format (current-error-port) "retrieving ~a files from '~a'...~%"
-                     (length files) host)
+      ;; Wait for completion of the remote process.
+      (let ((result (zero? (channel-get-exit-status port))))
+        (close-port port)
+        result))))
 
-             ;; We cannot use the 'import-paths' RPC here because we already
-             ;; hold the locks for FILES.
-             (call-with-decompressed-port 'xz pipe
-               (lambda (decompressed)
-                 (restore-file-set decompressed
-                                   #:log-port (current-error-port)
-                                   #:lock? #f)))
+(define (retrieve-files files remote)
+  "Retrieve FILES from SESSION's store, and import them."
+  (let* ((session (channel-get-session (nix-server-socket remote)))
+         (host    (session-get session 'host))
+         (port    (store-export-channel session files)))
+    (format #t (_ "retrieving ~a files from '~a'...~%")
+            (length files) host)
 
-             ;; Wait for the 'lsh' process to complete.
-             (zero? (close-pipe pipe)))))))
+    ;; We cannot use the 'import-paths' RPC here because we already
+    ;; hold the locks for FILES.
+    (let ((result (restore-file-set port
+                                    #:log-port (current-error-port)
+                                    #:lock? #f)))
+      (close-port port)
+      result)))
 
 
 ;;;
@@ -547,13 +490,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

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."

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],

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 +=					\