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

Merge branch 'master' into core-updates

This commit is contained in:
Leo Famulari 2016-11-26 16:21:47 -05:00
parent 3ad8cb4163 cd65d600ac
commit a282cdae10
No known key found for this signature in database
GPG Key ID: 2646FA30BACA7F08
58 changed files with 3506 additions and 1231 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitignore vendored
View File

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

9
.mailmap
View File

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

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

@ -61,6 +61,8 @@
(define guile-json
(first (find-best-packages-by-name "guile-json" #f)))
(define guile-ssh
(first (find-best-packages-by-name "guile-ssh" #f)))
;; The actual build procedure.
@ -103,8 +105,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

16
config-daemon.ac
View File

@ -128,12 +128,20 @@ if test "x$guix_build_daemon" = "xyes"; then
dnl 'restore-file-set', which requires unbuffered custom binary input
dnl ports from Guile >= 2.0.10.)
GUIX_CHECK_UNBUFFERED_CBIP
guix_build_daemon_offload="$ac_cv_guix_cbips_support_setvbuf"
if test "x$guix_build_daemon_offload" = "xyes"; then
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.])
fi
[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

216
doc/guix.texi
View File

@ -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!
(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.

12
etc/guix-publish.conf.in Normal file
View File

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

19
etc/guix-publish.service.in Normal file
View File

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

5
gnu/build/install.scm
View File

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

73
gnu/build/marionette.scm
View File

@ -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")
(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
(alarm 0)
(display "marionette is ready\n")
(marionette (append command extra-options) pid
monitor-conn repl-conn)))))))))))
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")

7
gnu/local.mk
View File

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

8
gnu/packages/aspell.scm
View File

@ -2,6 +2,7 @@
;;; 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 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")))

22
gnu/packages/audio.scm
View File

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

56
gnu/packages/bioinformatics.scm
View File

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

5
gnu/packages/bittorrent.scm
View File

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

11
gnu/packages/chez.scm
View File

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

10
gnu/packages/compression.scm
View File

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

4
gnu/packages/cups.scm
View File

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

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

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

154
gnu/packages/engineering.scm
View File

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

5
gnu/packages/gstreamer.scm
View File

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

4
gnu/packages/imagemagick.scm
View File

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

20
gnu/packages/ldc.scm
View File

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

4
gnu/packages/linux.scm
View File

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

5
gnu/packages/maths.scm
View File

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

196
gnu/packages/messaging.scm
View File

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

8
gnu/packages/music.scm
View File

@ -234,7 +234,7 @@ many input formats and provides a customisable Vi-style user interface.")
(define-public hydrogen
(package
(name "hydrogen")
(version "0.9.6.1")
(version "0.9.7")
(source (origin
(method url-fetch)
(uri (string-append
@ -242,7 +242,7 @@ many input formats and provides a customisable Vi-style user interface.")
version ".tar.gz"))
(sha256
(base32
"0vxnaqfmcv7hhk0cj67imdcqngspnck7f0wfmvhfgfqa7x1xznll"))))
"1dy2jfkdw0nchars4xi4isrz66fqn53a9qk13bqza7lhmsg3s3qy"))))
(build-system cmake-build-system)
(arguments
`(#:test-target "tests"))
@ -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

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

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

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

File diff suppressed because it is too large Load Diff

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

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

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

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

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

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

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

@ -4,19 +4,9 @@ two others use networking. Not bad out of almost 700 tests!
by Pjotr Prins <pjotr.guix@thebird.nl>
diff --git a/std/datetime.d b/std/datetime.d
index 8e4ed3b..6c15bc5 100644
--- a/std/datetime.d
+++ b/std/datetime.d
@@ -28018,6 +28018,7 @@ public:
The default directory where the TZ Database files are. It's empty
for Windows, since Windows doesn't have them.
+/
+
enum defaultTZDatabaseDir = "/usr/share/zoneinfo/";
}
else version(Windows)
@@ -28069,14 +28070,13 @@ assert(tz.dstName == "PDT");
--- a/std/datetime.d.orig 2016-11-24 01:13:52.584495545 +0100
+++ b/std/datetime.d 2016-11-24 01:17:09.655306728 +0100
@@ -28081,22 +28081,24 @@
import std.range : retro;
import std.format : format;
@ -25,9 +15,20 @@ index 8e4ed3b..6c15bc5 100644
enforce(tzDatabaseDir.exists(), new DateTimeException(format("Directory %s does not exist.", tzDatabaseDir)));
enforce(tzDatabaseDir.isDir, new DateTimeException(format("%s is not a directory.", tzDatabaseDir)));
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

31
gnu/packages/perl.scm
View File

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

227
gnu/packages/psyc.scm
View File

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

44
gnu/packages/python.scm
View File

@ -31,6 +31,7 @@
;;; Copyright © 2016 Dylan Jeffers <sapientech@sapientech@openmailbox.org>
;;; Copyright © 2016 Alex Vong <alexvong1995@gmail.com>
;;; Copyright © 2016 Arun Isaac <arunisaac@systemreboot.net>
;;; Copyright © 2016 Julien Lepiller <julien@lepiller.eu>
;;;
;;; This file is part of GNU Guix.
;;;
@ -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

2
gnu/packages/qemu.scm
View File

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

17
gnu/packages/ssh.scm
View File

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

112
gnu/packages/telephony.scm
View File

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

27
gnu/packages/upnp.scm
View File

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

4
gnu/packages/video.scm
View File

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

4
gnu/packages/vim.scm
View File

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

5
gnu/packages/web.scm
View File

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

81
gnu/packages/wxwidgets.scm
View File

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

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

@ -0,0 +1,205 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Andy Wingo <wingo@igalia.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu services configuration)
#:use-module (guix packages)
#:use-module (guix records)
#:use-module (guix gexp)
#:autoload (texinfo) (texi-fragment->stexi)
#:autoload (texinfo serialize) (stexi->texi)
#:use-module (ice-9 match)
#:use-module ((srfi srfi-1) #:select (append-map))
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:export (configuration-field
configuration-field-name
configuration-missing-field
configuration-field-error
serialize-configuration
define-configuration
validate-configuration
generate-documentation
serialize-field
serialize-string
serialize-name
serialize-space-separated-string-list
space-separated-string-list?
serialize-file-name
file-name?
serialize-boolean
serialize-package))
;;; Commentary:
;;;
;;; Syntax for creating Scheme bindings to complex configuration files.
;;;
;;; Code:
(define-condition-type &configuration-error &error
configuration-error?)
(define (configuration-error message)
(raise (condition (&message (message message))
(&configuration-error))))
(define (configuration-field-error field val)
(configuration-error
(format #f "Invalid value for field ~a: ~s" field val)))
(define (configuration-missing-field kind field)
(configuration-error
(format #f "~a configuration missing required field ~a" kind field)))
(define-record-type* <configuration-field>
configuration-field make-configuration-field configuration-field?
(name configuration-field-name)
(type configuration-field-type)
(getter configuration-field-getter)
(predicate configuration-field-predicate)
(serializer configuration-field-serializer)
(default-value-thunk configuration-field-default-value-thunk)
(documentation configuration-field-documentation))
(define (serialize-configuration config fields)
(for-each (lambda (field)
((configuration-field-serializer field)
(configuration-field-name field)
((configuration-field-getter field) config)))
fields))
(define (validate-configuration config fields)
(for-each (lambda (field)
(let ((val ((configuration-field-getter field) config)))
(unless ((configuration-field-predicate field) val)
(configuration-field-error
(configuration-field-name field) val))))
fields))
(define-syntax define-configuration
(lambda (stx)
(define (id ctx part . parts)
(let ((part (syntax->datum part)))
(datum->syntax
ctx
(match parts
(() part)
(parts (symbol-append part
(syntax->datum (apply id ctx parts))))))))
(syntax-case stx ()
((_ stem (field (field-type def) doc) ...)
(with-syntax (((field-getter ...)
(map (lambda (field)
(id #'stem #'stem #'- field))
#'(field ...)))
((field-predicate ...)
(map (lambda (type)
(id #'stem type #'?))
#'(field-type ...)))
((field-serializer ...)
(map (lambda (type)
(id #'stem #'serialize- type))
#'(field-type ...))))
#`(begin
(define-record-type* #,(id #'stem #'< #'stem #'>)
#,(id #'stem #'% #'stem)
#,(id #'stem #'make- #'stem)
#,(id #'stem #'stem #'?)
(field field-getter (default def))
...)
(define #,(id #'stem #'stem #'-fields)
(list (configuration-field
(name 'field)
(type 'field-type)
(getter field-getter)
(predicate field-predicate)
(serializer field-serializer)
(default-value-thunk (lambda () def))
(documentation doc))
...))
(define-syntax-rule (stem arg (... ...))
(let ((conf (#,(id #'stem #'% #'stem) arg (... ...))))
(validate-configuration conf
#,(id #'stem #'stem #'-fields))
conf))))))))
(define (uglify-field-name field-name)
(let ((str (symbol->string field-name)))
(string-concatenate
(map string-titlecase
(string-split (if (string-suffix? "?" str)
(substring str 0 (1- (string-length str)))
str)
#\-)))))
(define (serialize-field field-name val)
(format #t "~a ~a\n" (uglify-field-name field-name) val))
(define (serialize-package field-name val)
#f)
(define (serialize-string field-name val)
(serialize-field field-name val))
(define (space-separated-string-list? val)
(and (list? val)
(and-map (lambda (x)
(and (string? x) (not (string-index x #\space))))
val)))
(define (serialize-space-separated-string-list field-name val)
(serialize-field field-name (string-join val " ")))
(define (file-name? val)
(and (string? val)
(string-prefix? "/" val)))
(define (serialize-file-name field-name val)
(serialize-string field-name val))
(define (serialize-boolean field-name val)
(serialize-string field-name (if val "yes" "no")))
;; A little helper to make it easier to document all those fields.
(define (generate-documentation documentation documentation-name)
(define (str x) (object->string x))
(define (generate configuration-name)
(match (assq-ref documentation configuration-name)
((fields . sub-documentation)
`((para "Available " (code ,(str configuration-name)) " fields are:")
,@(map
(lambda (f)
(let ((field-name (configuration-field-name f))
(field-type (configuration-field-type f))
(field-docs (cdr (texi-fragment->stexi
(configuration-field-documentation f))))
(default (catch #t
(configuration-field-default-value-thunk f)
(lambda _ '%invalid))))
(define (show-default? val)
(or (string? default) (number? default) (boolean? default)
(and (symbol? val) (not (eq? val '%invalid)))
(and (list? val) (and-map show-default? val))))
`(deftypevr (% (category
(code ,(str configuration-name)) " parameter")
(data-type ,(str field-type))
(name ,(str field-name)))
,@field-docs
,@(if (show-default? default)
`((para "Defaults to " (samp ,(str default)) "."))
'())
,@(append-map
generate
(or (assq-ref sub-documentation field-name) '())))))
fields)))))
(stexi->texi `(*fragment* . ,(generate documentation-name))))

176
gnu/services/cups.scm
View File

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

94
gnu/services/dbus.scm
View File

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

93
gnu/services/desktop.scm
View File

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

6
gnu/services/kerberos.scm
View File

@ -38,13 +38,15 @@
"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
(arguments
(list
(format #f "minimum_uid=~a"
(pam-krb5-configuration-minimum-uid config)))))))
(pam-service

263
gnu/services/mail.scm
View File

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

3
gnu/services/networking.scm
View File

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

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

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

8
gnu/system/mapped-devices.scm
View File

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

39
gnu/tests/base.scm
View File

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

66
gnu/tests/install.scm
View File

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

538
guix/scripts/offload.scm
View File

@ -17,6 +17,13 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix scripts offload)
#:use-module (ssh key)
#:use-module (ssh auth)
#:use-module (ssh session)
#:use-module (ssh channel)
#:use-module (ssh popen)
#:use-module (ssh dist)
#:use-module (ssh dist node)
#:use-module (guix config)
#:use-module (guix records)
#:use-module (guix store)
@ -65,14 +72,15 @@
(system build-machine-system) ; string
(user build-machine-user) ; string
(private-key build-machine-private-key ; file name
(default (user-lsh-private-key)))
(default (user-openssh-private-key)))
(host-key build-machine-host-key) ; string
(daemon-socket build-machine-daemon-socket ; string
(default "/var/guix/daemon-socket/socket"))
(parallel-builds build-machine-parallel-builds ; number
(default 1))
(speed build-machine-speed ; inexact real
(default 1.0))
(features build-machine-features ; list of strings
(default '()))
(ssh-options build-machine-ssh-options ; list of strings
(default '())))
(define-record-type* <build-requirements>
@ -86,19 +94,11 @@
;; File that lists machines available as build slaves.
(string-append %config-directory "/machines.scm"))
(define %lsh-command
"lsh")
(define %lshg-command
;; FIXME: 'lshg' fails to pass large amounts of data, see
;; <http://lists.lysator.liu.se/pipermail/lsh-bugs/2014q1/000639.html>.
"lsh")
(define (user-lsh-private-key)
"Return the user's default lsh private key, or #f if it could not be
(define (user-openssh-private-key)
"Return the user's default SSH private key, or #f if it could not be
determined."
(and=> (getenv "HOME")
(cut string-append <> "/.lsh/identity")))
(cut string-append <> "/.ssh/id_rsa")))
(define %user-module
;; Module in which the machine description file is loaded.
@ -134,81 +134,120 @@ determined."
(leave (_ "failed to load machine file '~a': ~s~%")
file args))))))
;;; FIXME: The idea was to open the connection to MACHINE once for all, but
;;; lshg is currently non-functional.
;; (define (open-ssh-gateway machine)
;; "Initiate an SSH connection gateway to MACHINE, and return the PID of the
;; running lsh gateway upon success, or #f on failure."
;; (catch 'system-error
;; (lambda ()
;; (let* ((port (open-pipe* OPEN_READ %lsh-command
;; "-l" (build-machine-user machine)
;; "-i" (build-machine-private-key machine)
;; ;; XXX: With lsh 2.1, passing '--write-pid'
;; ;; last causes the PID not to be printed.
;; "--write-pid" "--gateway" "--background"
;; (build-machine-name machine)))
;; (line (read-line port))
;; (status (close-pipe port)))
;; (if (zero? status)
;; (let ((pid (string->number line)))
;; (if (integer? pid)
;; pid
;; (begin
;; (warning (_ "'~a' did not write its PID on stdout: ~s~%")
;; %lsh-command line)
;; #f)))
;; (begin
;; (warning (_ "failed to initiate SSH connection to '~a':\
;; '~a' exited with ~a~%")
;; (build-machine-name machine)
;; %lsh-command
;; (status:exit-val status))
;; #f))))
;; (lambda args
;; (leave (_ "failed to execute '~a': ~a~%")
;; %lsh-command (strerror (system-error-errno args))))))
(define (host-key->type+key host-key)
"Destructure HOST-KEY, an OpenSSH host key string, and return two values:
its key type as a symbol, and the actual base64-encoded string."
(define (type->symbol type)
(and (string-prefix? "ssh-" type)
(string->symbol (string-drop type 4))))
(define-syntax with-error-to-port
(syntax-rules ()
((_ port exp0 exp ...)
(let ((new port)
(old (current-error-port)))
(dynamic-wind
(match (string-tokenize host-key)
((type key _)
(values (type->symbol type) key))
((type key)
(values (type->symbol type) key))))
(define (private-key-from-file* file)
"Like 'private-key-from-file', but raise an error that 'with-error-handling'
can interpret meaningfully."
(catch 'guile-ssh-error
(lambda ()
(set-current-error-port new))
(lambda ()
exp0 exp ...)
(lambda ()
(set-current-error-port old)))))))
(private-key-from-file file))
(lambda (key proc str . rest)
(raise (condition
(&message (message (format #f (_ "failed to load SSH \
private key from '~a': ~a")
file str))))))))
(define* (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 (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)
;; 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))
;; We need lightweight compression when
;; exchanging full archives.
#:compression "zlib"
#:compression-level 3)))
(connect! session)
;; XXX: Remove '-i' when %LSHG-COMMAND really is lshg.
"-i" (build-machine-private-key machine)
;; 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)))
(append (build-machine-ssh-options machine)
(list (build-machine-name machine))
(if quote?
(map shell-quote command)
command)))))
(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?
(define session
(open-ssh-session machine))
(define store
(connect-to-remote-daemon session
(build-machine-daemon-socket machine)))
(set-build-options store
#:print-build-trace print-build-trace?
#:max-silent-time max-silent-time
#:build-timeout build-timeout)))
(if (zero? status)
(begin
(retrieve-files outputs machine)
(remove-gc-roots machine)
#: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)
"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 '~a' offloaded to '~a' failed: ~a~%")
(derivation-file-name drv)
(build-machine-name machine)
(status:exit-val status))
(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))))))
(primitive-exit 100)))
(build-derivations store (list drv)))
(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)))
(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
(guard (c ((nix-protocol-error? c)
(warning (_ "failed to export files for '~a': ~s~%")
(build-machine-name machine)
c)
#f))
(setvbuf (current-input-port) _IONBF)
(import-paths store (current-input-port)))))
;; Compute the subset of FILES missing on MACHINE, and send them in
(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
;; Compute the subset of FILES missing on SESSION, 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"))
(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))
;; Wait for the 'lsh' process to complete.
(zero? (close-pipe pipe))))))
(define (retrieve-files files machine)
"Retrieve FILES from MACHINE's store, and import them."
(define host
(build-machine-name machine))
(let ((pipe (remote-pipe machine OPEN_READ
`("guix" "archive" "--export" ,@files
"|" "xz" "-c")
#:quote? #f)))
(and pipe
(with-store store
(guard (c ((nix-protocol-error? c)
(warning (_ "failed to import files from '~a': ~s~%")
host c)
#f))
(format (current-error-port) "retrieving ~a files from '~a'...~%"
(remove (cut valid-path? store <>)
',sorted)))))
(port (store-import-channel session)))
(format #t (_ "sending ~a store files to '~a'...~%")
(length missing) (session-get session 'host))
(export-paths store missing port)
;; Tell the remote process that we're done. (In theory the
;; end-of-archive mark of 'export-paths' would be enough, but in
;; practice it's not.)
(channel-send-eof port)
;; Wait for completion of the remote process.
(let ((result (zero? (channel-get-exit-status port))))
(close-port port)
result))))
(define (retrieve-files files remote)
"Retrieve FILES from SESSION's store, and import them."
(let* ((session (channel-get-session (nix-server-socket remote)))
(host (session-get session 'host))
(port (store-export-channel session files)))
(format #t (_ "retrieving ~a files from '~a'...~%")
(length files) host)
;; We cannot use the 'import-paths' RPC here because we already
;; hold the locks for FILES.
(call-with-decompressed-port 'xz pipe
(lambda (decompressed)
(restore-file-set decompressed
(let ((result (restore-file-set port
#:log-port (current-error-port)
#:lock? #f)))
;; Wait for the 'lsh' process to complete.
(zero? (close-pipe pipe)))))))
(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

50
guix/store.scm
View File

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

18
m4/guix.m4
View File

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

16
nix/local.mk
View File

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