Merge branch 'master' into core-updates

This commit is contained in:
Leo Famulari 2016-11-26 16:21:47 -05:00
commit a282cdae10
No known key found for this signature in database
GPG Key ID: 2646FA30BACA7F08
58 changed files with 3506 additions and 1231 deletions

2
.gitignore vendored
View File

@ -50,6 +50,8 @@
/emacs/guix-helper.scm /emacs/guix-helper.scm
/etc/guix-daemon.conf /etc/guix-daemon.conf
/etc/guix-daemon.service /etc/guix-daemon.service
/etc/guix-publish.conf
/etc/guix-publish.service
/guix-daemon /guix-daemon
/guix-register /guix-register
/guix/config.scm /guix/config.scm

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> <mthl@openmailbox.org>
Mathieu Lirzin <mthl@gnu.org> <mathieu.lirzin@openmailbox.org> Mathieu Lirzin <mthl@gnu.org> <mathieu.lirzin@openmailbox.org>
Nikita Karetnikov <nikita@karetnikov.org> <nikita.karetnikov@gmail.com> Nikita Karetnikov <nikita@karetnikov.org> <nikita.karetnikov@gmail.com>
ng0 <ng0@we.make.ritual.n0.is> <ngillmann@runbox.com> ng0 <ng0@libertad.pw> <ng0@we.make.ritual.n0.is>
ng0 <ng0@we.make.ritual.n0.is> <niasterisk@grrlz.net> ng0 <ng0@libertad.pw> <ngillmann@runbox.com>
ng0 <ng0@we.make.ritual.n0.is> <ng@niasterisk.space> ng0 <ng0@libertad.pw> <niasterisk@grrlz.net>
ng0 <ng0@we.make.ritual.n0.is> <ng0@libertad.pw> ng0 <ng0@libertad.pw> <ng@niasterisk.space>
ng0 <ng0@libertad.pw>
Pjotr Prins <pjotr.public01@thebird.nl> Pjotr Prins <pjotr.public01@thebird.nl>
Pjotr Prins <pjotr.public01@thebird.nl> <pjotr.public12@thebird.nl> Pjotr Prins <pjotr.public01@thebird.nl> <pjotr.public12@thebird.nl>
Raimon Grau <raimonster@gmail.com> <raimon@3scale.net> Raimon Grau <raimonster@gmail.com> <raimon@3scale.net>

View File

@ -61,6 +61,8 @@
(define guile-json (define guile-json
(first (find-best-packages-by-name "guile-json" #f))) (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. ;; The actual build procedure.
@ -103,8 +105,14 @@ files."
(use-modules (guix build pull)) (use-modules (guix build pull))
(let ((json (string-append #$guile-json "/share/guile/site/2.0"))) (let ((json (string-append #$guile-json "/share/guile/site/2.0")))
(set! %load-path (cons json %load-path)) (set! %load-path
(set! %load-compiled-path (cons json %load-compiled-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 (build-guix #$output #$source

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 'restore-file-set', which requires unbuffered custom binary input
dnl ports from Guile >= 2.0.10.) dnl ports from Guile >= 2.0.10.)
GUIX_CHECK_UNBUFFERED_CBIP 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'.
AC_DEFINE([HAVE_DAEMON_OFFLOAD_HOOK], [1], GUIX_CHECK_GUILE_SSH
[Define if the daemon's 'offload' build hook is being built.])
fi case "x$ac_cv_guix_cbips_support_setvbuf$guix_cv_have_recent_guile_ssh" in
xyesyes)
guix_build_daemon_offload="yes"
AC_DEFINE([HAVE_DAEMON_OFFLOAD_HOOK], [1],
[Define if the daemon's 'offload' build hook is being built (requires Guile-SSH).])
;;
*)
guix_build_daemon_offload="no"
;;
esac
dnl Temporary directory used to store the daemon's data. dnl Temporary directory used to store the daemon's data.
GUIX_TEST_ROOT_DIRECTORY GUIX_TEST_ROOT_DIRECTORY

View File

@ -453,7 +453,7 @@ If your host distro uses the systemd init system, this can be achieved
with these commands: with these commands:
@example @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/ /etc/systemd/system/
# systemctl start guix-daemon && systemctl enable guix-daemon # systemctl start guix-daemon && systemctl enable guix-daemon
@end example @end example
@ -461,7 +461,7 @@ with these commands:
If your host distro uses the Upstart init system: If your host distro uses the Upstart init system:
@example @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 # start guix-daemon
@end example @end example
@ -566,6 +566,12 @@ allow you to use the @command{guix import pypi} command (@pxref{Invoking
guix import}). It is of guix import}). It is of
interest primarily for developers and not for casual users. 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 @item
When @url{http://zlib.net, zlib} is available, @command{guix publish} When @url{http://zlib.net, zlib} is available, @command{guix publish}
can compress build byproducts (@pxref{Invoking 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 offloading
@cindex build hook @cindex build hook
When desired, the build daemon can @dfn{offload} When desired, the build daemon can @dfn{offload} derivation builds to
derivation builds to other machines other machines running Guix, using the @code{offload} @dfn{build
running Guix, using the @code{offload} @dfn{build hook}. When that 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 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 @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 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 (list (build-machine
(name "eightysix.example.org") (name "eightysix.example.org")
(system "x86_64-linux") (system "x86_64-linux")
(host-key "ssh-ed25519 AAAAC3Nza@dots{}")
(user "bob") (user "bob")
(speed 2.)) ; incredibly fast! (speed 2.)) ;incredibly fast!
(build-machine (build-machine
(name "meeps.example.org") (name "meeps.example.org")
(system "mips64el-linux") (system "mips64el-linux")
(host-key "ssh-rsa AAAAB3Nza@dots{}")
(user "alice") (user "alice")
(private-key (private-key
(string-append (getenv "HOME") (string-append (getenv "HOME")
"/.lsh/identity-for-guix")))) "/.ssh/identity-for-guix"))))
@end example @end example
@noindent @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 Note that the SSH key pair must @emph{not} be passphrase-protected, to
allow non-interactive logins. 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 @end table
A number of optional fields may be specified: A number of optional fields may be specified:
@table @code @table @asis
@item port @item @code{port} (default: @code{22})
Port number of SSH server on the machine (default: 22). Port number of SSH server on the machine.
@item private-key @item @code{private-key} (default: @file{~/.ssh/id_rsa})
The SSH private key file to use when connecting to the machine. 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 @item @code{daemon-socket} (default: @code{"/var/guix/daemon-socket/socket"})
(@pxref{Invoking lsh,,, GNU lsh Manual}). Thus, the key file here must File name of the Unix-domain socket @command{guix-daemon} is listening
be an lsh key file. This may change in the future, though. to on that machine.
@item parallel-builds @item @code{parallel-builds} (default: @code{1})
The number of builds that may run in parallel on the machine (1 by The number of builds that may run in parallel on the machine.
default.)
@item speed @item @code{speed} (default: @code{1.0})
A ``relative speed factor''. The offload scheduler will tend to prefer A ``relative speed factor''. The offload scheduler will tend to prefer
machines with a higher speed factor. machines with a higher speed factor.
@item features @item @code{features} (default: @code{'()})
A list of strings denoting specific features supported by the machine. A list of strings denoting specific features supported by the machine.
An example is @code{"kvm"} for machines that have the KVM Linux modules An example is @code{"kvm"} for machines that have the KVM Linux modules
and corresponding hardware support. Derivations can request features by 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: this is the case by running:
@example @example
lsh build-machine guile -c "'(use-modules (guix config))'" ssh build-machine guile -c "'(use-modules (guix config))'"
@end example @end example
There is one last thing to do once @file{machines.scm} is in place. As 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, of the @code{operating-system} declaration (@pxref{guix-publish-service,
@code{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 @node Invoking guix challenge
@section Invoking @command{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 mkfs.ext4 -L my-root /dev/sda1
@end example @end example
@c FIXME: Uncomment this once GRUB fully supports encrypted roots. @cindex encrypted disk
@c A typical command sequence may be: If you are instead planning to encrypt the root partition, you can use
@c the Cryptsetup/LUKS utilities to do that (see @inlinefmtifelse{html,
@c @example @uref{https://linux.die.net/man/8/cryptsetup, @code{man cryptsetup}},
@c # fdisk /dev/sdX @code{man cryptsetup}} for more information.) Assuming you want to
@c @dots{} Create partitions etc.@dots{} store the root partition on @file{/dev/sda1}, the command sequence would
@c # cryptsetup luksFormat /dev/sdX1 be along these lines:
@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):
@example @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 @end example
Finally, if you plan to use one or more swap partitions (@pxref{Memory 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 @code{device} fields in your @code{file-system} configuration, assuming
your @code{file-system} configuration sets the value of @code{title} to your @code{file-system} configuration sets the value of @code{title} to
@code{'label}. @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 @end itemize
Once you are done preparing the configuration file, the new system must 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 to create a new configuration which has the same values as the old
configuration, but with a few modifications. 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 server, GNOME and Xfce (users can choose which of these desktop
environments to use at the log-in screen by pressing @kbd{F1}), network environments to use at the log-in screen by pressing @kbd{F1}), network
management, power management, and more, would look like this: 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. When true, the mount point is created if it does not exist yet.
@item @code{dependencies} (default: @code{'()}) @item @code{dependencies} (default: @code{'()})
This is a list of @code{<file-system>} objects representing file systems This is a list of @code{<file-system>} or @code{<mapped-device>} objects
that must be mounted before (and unmounted after) this one. 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 As an example, consider a hierarchy of mounts: @file{/sys/fs/cgroup} is
a dependency of @file{/sys/fs/cgroup/cpu} and a dependency of @file{/sys/fs/cgroup/cpu} and
@file{/sys/fs/cgroup/memory}. @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 table
@end deftp @end deftp
@ -8407,13 +8472,22 @@ configure networking."
@end deffn @end deffn
@cindex WPA Supplicant @cindex WPA Supplicant
@deffn {Scheme Procedure} wpa-supplicant-service @ @defvr {Scheme Variable} wpa-supplicant-service-type
[#:wpa-supplicant @var{wpa-supplicant}] This is the service type to run @url{https://w1.fi/wpa_supplicant/,WPA
Return a service that runs @url{https://w1.fi/wpa_supplicant/,WPA
supplicant}, an authentication daemon required to authenticate against 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. 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 NTP
@cindex real time clock @cindex real time clock
@ -9979,7 +10053,7 @@ Return a service that runs @command{mysqld}, the MySQL or MariaDB
database server. database server.
The optional @var{config} argument specifies the configuration for 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 @end deffn
@deftp {Data Type} mysql-configuration @deftp {Data Type} mysql-configuration
@ -10001,16 +10075,11 @@ For MariaDB, the root password is empty.
@cindex mail @cindex mail
@cindex email @cindex email
The @code{(gnu services mail)} module provides Guix service definitions The @code{(gnu services mail)} module provides Guix service definitions
for mail services. Currently the only implemented service is Dovecot, for email services: IMAP, POP3, and LMTP servers, as well as mail
an IMAP, POP3, and LMTP server. 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 @subsubheading Dovecot Service
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:
@deffn {Scheme Procedure} dovecot-service [#:config (dovecot-configuration)] @deffn {Scheme Procedure} dovecot-service [#:config (dovecot-configuration)]
Return a service that runs the Dovecot IMAP/POP3/LMTP mail server. Return a service that runs the Dovecot IMAP/POP3/LMTP mail server.
@ -11366,18 +11435,47 @@ could instantiate a dovecot service like this:
(string ""))) (string "")))
@end example @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 @node Kerberos Services
@subsubsection Kerberos Services @subsubsection Kerberos Services
@cindex Kerberos @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}. the authentication protocol @dfn{Kerberos}.
@subsubheading PAM krb5 Service @subsubheading PAM krb5 Service
@cindex pam-krb5 @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. management via Kerberos.
You will need this service if you want PAM enabled applications to authenticate You will need this service if you want PAM enabled applications to authenticate
users using Kerberos. 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

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

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 so that the fonts, background images, etc. referred to by GRUB.CFG are not
GC'd." GC'd."
(install-grub-config grub.cfg mount-point) (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" (unless (zero? (system* "grub-install" "--no-floppy"
"--boot-directory" "--boot-directory"
(string-append mount-point "/boot") (string-append mount-point "/boot")

View File

@ -21,10 +21,13 @@
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (rnrs io ports) #:use-module (rnrs io ports)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 popen)
#:export (marionette? #:export (marionette?
make-marionette make-marionette
marionette-eval marionette-eval
marionette-control marionette-control
marionette-screen-text
wait-for-screen-text
%qwerty-us-keystrokes %qwerty-us-keystrokes
marionette-type)) marionette-type))
@ -45,7 +48,10 @@
(command marionette-command) ;list of strings (command marionette-command) ;list of strings
(pid marionette-pid) ;integer (pid marionette-pid) ;integer
(monitor marionette-monitor) ;port (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)) (define* (wait-for-monitor-prompt port #:key (quiet? #t))
"Read from PORT until we have seen all of QEMU's monitor prompt. When "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) (close-port monitor)
(wait-for-monitor-prompt monitor-conn) (wait-for-monitor-prompt monitor-conn)
(display "read QEMU monitor prompt\n") (display "read QEMU monitor prompt\n")
(match (accept* repl)
((repl-conn . addr) (marionette (append command extra-options) pid
(display "connected to guest REPL\n") monitor-conn
(close-port repl)
(match (read repl-conn) ;; The following 'accept' call connects immediately, but
('ready ;; we don't know whether the guest has connected until
(alarm 0) ;; we actually receive the 'ready' message.
(display "marionette is ready\n") (match (accept* repl)
(marionette (append command extra-options) pid ((repl-conn . addr)
monitor-conn repl-conn))))))))))) (display "connected to guest REPL\n")
(close-port repl)
;; Delay reception of the 'ready' message so that the
;; caller can already send monitor commands.
(delay
(match (read repl-conn)
('ready
(display "marionette is ready\n")
repl-conn))))))))))))
(define (marionette-eval exp marionette) (define (marionette-eval exp marionette)
"Evaluate EXP in MARIONETTE's backdoor REPL. Return the result." "Evaluate EXP in MARIONETTE's backdoor REPL. Return the result."
(match marionette (match marionette
(($ <marionette> command pid monitor repl) (($ <marionette> command pid monitor (= force repl))
(write exp repl) (write exp repl)
(newline repl) (newline repl)
(read repl)))) (read repl))))
@ -160,6 +174,55 @@ pcsys_monitor\")."
(newline monitor) (newline monitor)
(wait-for-monitor-prompt 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 (define %qwerty-us-keystrokes
;; Maps "special" characters to their keystrokes. ;; Maps "special" characters to their keystrokes.
'((#\newline . "ret") '((#\newline . "ret")

View File

@ -305,7 +305,6 @@ GNU_SYSTEM_MODULES = \
%D%/packages/pumpio.scm \ %D%/packages/pumpio.scm \
%D%/packages/pretty-print.scm \ %D%/packages/pretty-print.scm \
%D%/packages/protobuf.scm \ %D%/packages/protobuf.scm \
%D%/packages/psyc.scm \
%D%/packages/pv.scm \ %D%/packages/pv.scm \
%D%/packages/python.scm \ %D%/packages/python.scm \
%D%/packages/qemu.scm \ %D%/packages/qemu.scm \
@ -400,6 +399,7 @@ GNU_SYSTEM_MODULES = \
%D%/services/admin.scm \ %D%/services/admin.scm \
%D%/services/avahi.scm \ %D%/services/avahi.scm \
%D%/services/base.scm \ %D%/services/base.scm \
%D%/services/configuration.scm \
%D%/services/cups.scm \ %D%/services/cups.scm \
%D%/services/databases.scm \ %D%/services/databases.scm \
%D%/services/dbus.scm \ %D%/services/dbus.scm \
@ -506,6 +506,7 @@ dist_patch_DATA = \
%D%/packages/patches/cssc-missing-include.patch \ %D%/packages/patches/cssc-missing-include.patch \
%D%/packages/patches/clucene-contribs-lib.patch \ %D%/packages/patches/clucene-contribs-lib.patch \
%D%/packages/patches/cursynth-wave-rand.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/dbus-helper-search-path.patch \
%D%/packages/patches/devil-CVE-2009-3994.patch \ %D%/packages/patches/devil-CVE-2009-3994.patch \
%D%/packages/patches/devil-fix-libpng.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-gets-undeclared.patch \
%D%/packages/patches/grub-freetype.patch \ %D%/packages/patches/grub-freetype.patch \
%D%/packages/patches/gsl-test-i686.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-1.8-cpp-4.5.patch \
%D%/packages/patches/guile-arm-fixes.patch \ %D%/packages/patches/guile-arm-fixes.patch \
%D%/packages/patches/guile-default-utf8.patch \ %D%/packages/patches/guile-default-utf8.patch \

View File

@ -1,7 +1,8 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com> ;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
;;; Copyright ©2016 John Darrington <jmd@gnu.org> ;;; Copyright © 2016 John Darrington <jmd@gnu.org>
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -155,3 +156,10 @@ dictionaries, including personal ones.")
#:sha256 #:sha256
(base32 (base32
"0ffb87yjsh211hllpc4b9khqqrblial4pzi1h9r3v465z1yhn3j4"))) "0ffb87yjsh211hllpc4b9khqqrblial4pzi1h9r3v465z1yhn3j4")))
(define-public aspell-dict-he
(aspell-dictionary "he" "Hebrew"
#:version "1.0-0"
#:sha256
(base32
"13bhbghx5b8g0119g3wxd4n8mlf707y41vlf59irxjj0kynankfn")))

View File

@ -8,6 +8,7 @@
;;; Copyright © 2016 Alex Griffin <a@ajgrf.com> ;;; Copyright © 2016 Alex Griffin <a@ajgrf.com>
;;; Copyright © 2016 ng0 <ng0@we.make.ritual.n0.is> ;;; Copyright © 2016 ng0 <ng0@we.make.ritual.n0.is>
;;; Copyright © 2016 Lukas Gradl <lgradl@openmailbox.org> ;;; Copyright © 2016 Lukas Gradl <lgradl@openmailbox.org>
;;; Copyright © 2016 Tobias Geerinckx-Rice <me@tobias.gr>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -1177,19 +1178,24 @@ well suited to all musical instruments and vocals.")
(version "1.3.2") (version "1.3.2")
(source (origin (source (origin
(method url-fetch) (method url-fetch)
(uri (string-append ;; The original home-page is gone. Download the tarball from an
"http://factorial.hu/system/files/ir.lv2-" ;; archive mirror instead.
version ".tar.gz")) (uri (list (string-append
"https://web.archive.org/web/20150803095032/"
"http://factorial.hu/system/files/ir.lv2-"
version ".tar.gz")
(string-append
"https://mirrors.kernel.org/gentoo/distfiles/ir.lv2-"
version ".tar.gz")))
(sha256 (sha256
(base32 (base32
"1jh2z01l9m4ar7yz0n911df07dygc7n4cl59p7qdjbh0nvkm747g")))) "1jh2z01l9m4ar7yz0n911df07dygc7n4cl59p7qdjbh0nvkm747g"))))
(build-system gnu-build-system) (build-system gnu-build-system)
(arguments (arguments
`(#:tests? #f ;no "check" target `(#:tests? #f ; no tests
#:make-flags (list (string-append "PREFIX=" (assoc-ref %outputs "out"))) #:make-flags (list (string-append "PREFIX=" (assoc-ref %outputs "out")))
#:phases #:phases (modify-phases %standard-phases
;; no configure script (delete 'configure)))) ; no configure script
(alist-delete 'configure %standard-phases)))
(inputs (inputs
`(("libsndfile" ,libsndfile) `(("libsndfile" ,libsndfile)
("libsamplerate" ,libsamplerate) ("libsamplerate" ,libsamplerate)
@ -1203,7 +1209,9 @@ well suited to all musical instruments and vocals.")
(list (search-path-specification (list (search-path-specification
(variable "LV2_PATH") (variable "LV2_PATH")
(files '("lib/lv2"))))) (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") (synopsis "LV2 convolution reverb")
(description (description
"IR is a low-latency, real-time, high performance signal convolver "IR is a low-latency, real-time, high performance signal convolver

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.") predicts the locations of structural units in the sequences.")
(license license:gpl2+))) (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 (define-public pyicoteo
(package (package
(name "pyicoteo") (name "pyicoteo")
@ -3765,7 +3817,7 @@ partial genes, and identifies translation initiation sites.")
(define-public roary (define-public roary
(package (package
(name "roary") (name "roary")
(version "3.6.8") (version "3.7.0")
(source (source
(origin (origin
(method url-fetch) (method url-fetch)
@ -3774,7 +3826,7 @@ partial genes, and identifies translation initiation sites.")
version ".tar.gz")) version ".tar.gz"))
(sha256 (sha256
(base32 (base32
"0g0pzcv8y7n2w8q7c9q0a7s2ghkwci6w8smg9mjw4agad5cd7yaw")))) "0x2hpb3nfsc6x2nq1788w0fhqfzc7cn2dp4xwyva9m3k6xlz0m43"))))
(build-system perl-build-system) (build-system perl-build-system)
(arguments (arguments
`(#:phases `(#:phases

View File

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

View File

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Federico Beffa <beffa@fbengineering.ch> ;;; Copyright © 2016 Federico Beffa <beffa@fbengineering.ch>
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -34,7 +35,8 @@
#:use-module (gnu packages compression) #:use-module (gnu packages compression)
#:use-module (gnu packages image) #:use-module (gnu packages image)
#:use-module (gnu packages xorg) #:use-module (gnu packages xorg)
#:use-module (ice-9 match)) #:use-module (ice-9 match)
#:use-module (srfi srfi-1))
(define nanopass (define nanopass
(let ((version "1.9")) (let ((version "1.9"))
@ -94,8 +96,7 @@
(list ,(match (or (%current-target-system) (%current-system)) (list ,(match (or (%current-target-system) (%current-system))
("x86_64-linux" '(list "--machine=ta6le")) ("x86_64-linux" '(list "--machine=ta6le"))
("i686-linux" '(list "--machine=ti3le")) ("i686-linux" '(list "--machine=ti3le"))
;; FIXME: Some people succeeded in cross-compiling to ;; Let autodetection have its attempt on other architectures.
;; ARM. https://github.com/cisco/ChezScheme/issues/13
(_ (_
'()))) '())))
#:phases #:phases
@ -191,7 +192,9 @@
(find-files lib "scheme.boot")) (find-files lib "scheme.boot"))
#t)))))) #t))))))
;; According to the documentation MIPS is not supported. ;; 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") (home-page "http://www.scheme.com")
(synopsis "R6RS Scheme compiler and run-time") (synopsis "R6RS Scheme compiler and run-time")
(description (description

View File

@ -603,24 +603,24 @@ writing of compressed data created with the zlib and bzip2 libraries.")
(define-public lz4 (define-public lz4
(package (package
(name "lz4") (name "lz4")
(version "131") (version "1.7.4.2")
(source (source
(origin (origin
(method url-fetch) (method url-fetch)
(uri (string-append "https://github.com/Cyan4973/lz4/archive/" (uri (string-append "https://github.com/Cyan4973/lz4/archive/"
"r" version ".tar.gz")) "v" version ".tar.gz"))
(sha256 (sha256
(base32 "1vfg305zvj50hwscad24wan9jar6nqj14gdk2hqyr7bb9mhh0kcx")) (base32 "0l39bymif15rmmfz7h6wvrr853rix4wj8wbqq8z8fm49xa7gx9fb"))
(file-name (string-append name "-" version ".tar.gz")))) (file-name (string-append name "-" version ".tar.gz"))))
(build-system gnu-build-system) (build-system gnu-build-system)
(native-inputs `(("valgrind" ,valgrind))) (native-inputs `(("valgrind" ,valgrind))) ; for tests
(arguments (arguments
`(#:test-target "test" `(#:test-target "test"
#:parallel-tests? #f ; tests fail if run in parallel #:parallel-tests? #f ; tests fail if run in parallel
#:make-flags (list "CC=gcc" #:make-flags (list "CC=gcc"
(string-append "PREFIX=" (assoc-ref %outputs "out"))) (string-append "PREFIX=" (assoc-ref %outputs "out")))
#:phases (modify-phases %standard-phases #:phases (modify-phases %standard-phases
(delete 'configure)))) (delete 'configure)))) ; no configure script
(home-page "https://github.com/Cyan4973/lz4") (home-page "https://github.com/Cyan4973/lz4")
(synopsis "Compression algorithm focused on speed") (synopsis "Compression algorithm focused on speed")
(description "LZ4 is a lossless compression algorithm, providing (description "LZ4 is a lossless compression algorithm, providing

View File

@ -317,14 +317,14 @@ device-specific programs to convert and print many types of files.")
(define-public hplip (define-public hplip
(package (package
(name "hplip") (name "hplip")
(version "3.16.10") (version "3.16.11")
(source (origin (source (origin
(method url-fetch) (method url-fetch)
(uri (string-append "mirror://sourceforge/hplip/hplip/" version (uri (string-append "mirror://sourceforge/hplip/hplip/" version
"/hplip-" version ".tar.gz")) "/hplip-" version ".tar.gz"))
(sha256 (sha256
(base32 (base32
"117f1p0splg51ljn4nn97c0mbl0jba440ahb3d8njq7p6h1lxd25")))) "094vkyr0rjng72m13dgr824cdl7q20x23qjxzih4w7l9njn0rqpn"))))
(build-system gnu-build-system) (build-system gnu-build-system)
(home-page "http://hplipopensource.com/") (home-page "http://hplipopensource.com/")
(synopsis "HP Printer Drivers") (synopsis "HP Printer Drivers")

View File

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

View File

@ -4,6 +4,7 @@
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2016 David Thompson <davet@gnu.org> ;;; Copyright © 2016 David Thompson <davet@gnu.org>
;;; Copyright © 2016 Ludovic Courtès <ludo@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. ;;; This file is part of GNU Guix.
;;; ;;;
@ -29,6 +30,7 @@
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix utils) #:use-module (guix utils)
#:use-module ((guix licenses) #:prefix license:) #:use-module ((guix licenses) #:prefix license:)
#:use-module (guix build-system cmake)
#:use-module (guix build-system gnu) #:use-module (guix build-system gnu)
#:use-module (guix build-system cmake) #:use-module (guix build-system cmake)
#:use-module (gnu packages) #:use-module (gnu packages)
@ -39,6 +41,7 @@
#:use-module (gnu packages boost) #:use-module (gnu packages boost)
#:use-module (gnu packages check) #:use-module (gnu packages check)
#:use-module (gnu packages compression) #:use-module (gnu packages compression)
#:use-module (gnu packages curl)
#:use-module (gnu packages flex) #:use-module (gnu packages flex)
#:use-module (gnu packages fontutils) #:use-module (gnu packages fontutils)
#:use-module (gnu packages gd) #:use-module (gnu packages gd)
@ -55,9 +58,14 @@
#:use-module (gnu packages maths) #:use-module (gnu packages maths)
#:use-module (gnu packages perl) #:use-module (gnu packages perl)
#:use-module (gnu packages pkg-config) #:use-module (gnu packages pkg-config)
#:use-module (gnu packages python)
#:use-module (gnu packages qt) #:use-module (gnu packages qt)
#:use-module (gnu packages swig)
#:use-module (gnu packages tcl) #:use-module (gnu packages tcl)
#:use-module (gnu packages tls)
#:use-module (gnu packages tex) #:use-module (gnu packages tex)
#:use-module (gnu packages wxwidgets)
#:use-module (gnu packages xorg)
#:use-module (srfi srfi-1)) #:use-module (srfi srfi-1))
(define-public librecad (define-public librecad
@ -588,3 +596,149 @@ fundamental, primitive shapes are represented as code in the user-level
language.") language.")
(license (list license:lgpl2.1+ ;library (license (list license:lgpl2.1+ ;library
license:gpl2+))))) ;Guile bindings 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+))))

View File

@ -4,6 +4,7 @@
;;; Copyright © 2015, 2016 Sou Bunnbu <iyzsong@gmail.com> ;;; Copyright © 2015, 2016 Sou Bunnbu <iyzsong@gmail.com>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2016 Leo Famulari <leo@famulari.name>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -207,6 +208,10 @@ for the GStreamer multimedia library.")
(uri (string-append (uri (string-append
"https://gstreamer.freedesktop.org/src/" name "/" "https://gstreamer.freedesktop.org/src/" name "/"
name "-" version ".tar.xz")) 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 (sha256
(base32 (base32
"1hkcap9l2603266gyi6jgvx7frbvfmb7xhfhjizbczy1wykjwr57")))) "1hkcap9l2603266gyi6jgvx7frbvfmb7xhfhjizbczy1wykjwr57"))))

View File

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

View File

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

View File

@ -2664,7 +2664,7 @@ and copy/paste text in the console and in xterm.")
(define-public btrfs-progs (define-public btrfs-progs
(package (package
(name "btrfs-progs") (name "btrfs-progs")
(version "4.8.3") (version "4.8.4")
(source (origin (source (origin
(method url-fetch) (method url-fetch)
(uri (string-append "mirror://kernel.org/linux/kernel/" (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")) "btrfs-progs-v" version ".tar.xz"))
(sha256 (sha256
(base32 (base32
"1wlflrygnpndppil9g12pk184f75g9qx1lkr0x1gijigglqhr9n1")))) "1ib1ybpjhcymcycjiraz1vk01qlyvpwcg7mwfhmacdy3cvbfl9mz"))))
(build-system gnu-build-system) (build-system gnu-build-system)
(outputs '("out" (outputs '("out"
"static")) ; static versions of binaries in "out" (~16MiB!) "static")) ; static versions of binaries in "out" (~16MiB!)

View File

@ -563,7 +563,10 @@ incompatible with HDF5.")
(inputs (inputs
`(("zlib" ,zlib))) `(("zlib" ,zlib)))
(arguments (arguments
`(#:phases `(;; Some of the users, notably Flann, need the C++ interface.
#:configure-flags '("--enable-cxx")
#:phases
(modify-phases %standard-phases (modify-phases %standard-phases
(add-before 'configure 'patch-configure (add-before 'configure 'patch-configure
(lambda _ (lambda _

View File

@ -5,7 +5,7 @@
;;; Copyright © 2015 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2015 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2015, 2016 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2015, 2016 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2015 Efraim Flashner <efraim@flashner.co.il> ;;; 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 Andy Patterson <ajpatter@uwaterloo.ca>
;;; Copyright © 2016 Clément Lassieur <clement@lassieur.org> ;;; Copyright © 2016 Clément Lassieur <clement@lassieur.org>
;;; ;;;
@ -33,6 +33,7 @@
#:use-module (guix build-system gnu) #:use-module (guix build-system gnu)
#:use-module (guix build-system glib-or-gtk) #:use-module (guix build-system glib-or-gtk)
#:use-module (guix build-system python) #:use-module (guix build-system python)
#:use-module (guix build-system perl)
#:use-module (gnu packages) #:use-module (gnu packages)
#:use-module (gnu packages aidc) #:use-module (gnu packages aidc)
#:use-module (gnu packages autotools) #:use-module (gnu packages autotools)
@ -43,11 +44,13 @@
#:use-module (gnu packages databases) #:use-module (gnu packages databases)
#:use-module (gnu packages documentation) #:use-module (gnu packages documentation)
#:use-module (gnu packages enchant) #:use-module (gnu packages enchant)
#:use-module (gnu packages gettext)
#:use-module (gnu packages gnome) #:use-module (gnu packages gnome)
#:use-module (gnu packages gtk) #:use-module (gnu packages gtk)
#:use-module (gnu packages xorg) #:use-module (gnu packages xorg)
#:use-module (gnu packages xdisorg) #:use-module (gnu packages xdisorg)
#:use-module (gnu packages libcanberra) #:use-module (gnu packages libcanberra)
#:use-module (gnu packages man)
#:use-module (gnu packages networking) #:use-module (gnu packages networking)
#:use-module (gnu packages libidn) #:use-module (gnu packages libidn)
#:use-module (gnu packages lua) #:use-module (gnu packages lua)
@ -57,6 +60,7 @@
#:use-module (gnu packages pkg-config) #:use-module (gnu packages pkg-config)
#:use-module (gnu packages glib) #:use-module (gnu packages glib)
#:use-module (gnu packages python) #:use-module (gnu packages python)
#:use-module (gnu packages pcre)
#:use-module (gnu packages perl) #:use-module (gnu packages perl)
#:use-module (gnu packages tcl) #:use-module (gnu packages tcl)
#:use-module (gnu packages compression) #:use-module (gnu packages compression)
@ -67,8 +71,10 @@
#:use-module (gnu packages icu4c) #:use-module (gnu packages icu4c)
#:use-module (gnu packages qt) #:use-module (gnu packages qt)
#:use-module (gnu packages video) #:use-module (gnu packages video)
#:use-module (gnu packages web)
#:use-module (gnu packages xiph) #:use-module (gnu packages xiph)
#:use-module (gnu packages audio) #:use-module (gnu packages audio)
#:use-module (gnu packages bison)
#:use-module (gnu packages fontutils)) #:use-module (gnu packages fontutils))
(define-public libotr (define-public libotr
@ -859,4 +865,192 @@ into existing applications.")
(home-page "https://camaya.net/gloox") (home-page "https://camaya.net/gloox")
(license license:gpl3))) (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 ;;; messaging.scm ends here

View File

@ -234,7 +234,7 @@ many input formats and provides a customisable Vi-style user interface.")
(define-public hydrogen (define-public hydrogen
(package (package
(name "hydrogen") (name "hydrogen")
(version "0.9.6.1") (version "0.9.7")
(source (origin (source (origin
(method url-fetch) (method url-fetch)
(uri (string-append (uri (string-append
@ -242,7 +242,7 @@ many input formats and provides a customisable Vi-style user interface.")
version ".tar.gz")) version ".tar.gz"))
(sha256 (sha256
(base32 (base32
"0vxnaqfmcv7hhk0cj67imdcqngspnck7f0wfmvhfgfqa7x1xznll")))) "1dy2jfkdw0nchars4xi4isrz66fqn53a9qk13bqza7lhmsg3s3qy"))))
(build-system cmake-build-system) (build-system cmake-build-system)
(arguments (arguments
`(#:test-target "tests")) `(#:test-target "tests"))
@ -1638,14 +1638,14 @@ computer's keyboard.")
(define-public qtractor (define-public qtractor
(package (package
(name "qtractor") (name "qtractor")
(version "0.7.9") (version "0.8.0")
(source (origin (source (origin
(method url-fetch) (method url-fetch)
(uri (string-append "http://downloads.sourceforge.net/qtractor/" (uri (string-append "http://downloads.sourceforge.net/qtractor/"
"qtractor-" version ".tar.gz")) "qtractor-" version ".tar.gz"))
(sha256 (sha256
(base32 (base32
"0pp459kfgrnngj373gnwwl43xjz32lmyf7v62p2nnjh6c7wr1ryq")))) "17v563liyqcvil204ry1qfp09d91944nqz2ig33f5c3pyg4z2427"))))
(build-system gnu-build-system) (build-system gnu-build-system)
(arguments `(#:tests? #f)) ; no "check" target (arguments `(#:tests? #f)) ; no "check" target
(inputs (inputs

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

File diff suppressed because it is too large Load Diff

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

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

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

View File

@ -4,19 +4,9 @@ two others use networking. Not bad out of almost 700 tests!
by Pjotr Prins <pjotr.guix@thebird.nl> by Pjotr Prins <pjotr.guix@thebird.nl>
diff --git a/std/datetime.d b/std/datetime.d --- a/std/datetime.d.orig 2016-11-24 01:13:52.584495545 +0100
index 8e4ed3b..6c15bc5 100644 +++ b/std/datetime.d 2016-11-24 01:17:09.655306728 +0100
--- a/std/datetime.d @@ -28081,22 +28081,24 @@
+++ 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");
import std.range : retro; import std.range : retro;
import std.format : format; 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.exists(), new DateTimeException(format("Directory %s does not exist.", tzDatabaseDir)));
enforce(tzDatabaseDir.isDir, new DateTimeException(format("%s is not a directory.", tzDatabaseDir))); enforce(tzDatabaseDir.isDir, new DateTimeException(format("%s is not a directory.", tzDatabaseDir)));
- immutable file = buildNormalizedPath(tzDatabaseDir, name); version(Android)
+ auto filename = "./" ~ strip(name); // make sure the prefix is not stripped {
+ immutable file = buildNormalizedPath(tzDatabaseDir, filename); + 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.", file)));
+ enforce(file.exists(), new DateTimeException(format("File %s does not exist in %s.", file, tzDatabaseDir))); + 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 index b85d1c9..7fbf346 100644
--- a/std/socket.d --- a/std/socket.d
+++ b/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 @@ -859,6 +862,8 @@ class InternetHost
unittest unittest

View File

@ -7,7 +7,7 @@
;;; Copyright © 2016 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2016 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2016 Jochem Raat <jchmrt@riseup.net> ;;; Copyright © 2016 Jochem Raat <jchmrt@riseup.net>
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il> ;;; 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 Alex Sassmannshausen <alex@pompo.co>
;;; Copyright © 2016 Roel Janssen <roel@gnu.org> ;;; Copyright © 2016 Roel Janssen <roel@gnu.org>
;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com> ;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com>
@ -2055,6 +2055,35 @@ each stack frame.")
interface for the RFC 2104 HMAC mechanism.") interface for the RFC 2104 HMAC mechanism.")
(license (package-license perl)))) (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 (define-public perl-digest-sha1
(package (package
(name "perl-digest-sha1") (name "perl-digest-sha1")

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

View File

@ -31,6 +31,7 @@
;;; Copyright © 2016 Dylan Jeffers <sapientech@sapientech@openmailbox.org> ;;; Copyright © 2016 Dylan Jeffers <sapientech@sapientech@openmailbox.org>
;;; Copyright © 2016 Alex Vong <alexvong1995@gmail.com> ;;; Copyright © 2016 Alex Vong <alexvong1995@gmail.com>
;;; Copyright © 2016 Arun Isaac <arunisaac@systemreboot.net> ;;; Copyright © 2016 Arun Isaac <arunisaac@systemreboot.net>
;;; Copyright © 2016 Julien Lepiller <julien@lepiller.eu>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -453,14 +454,14 @@ pidof, tty, taskset, pmap.")
(define-public python-passlib (define-public python-passlib
(package (package
(name "python-passlib") (name "python-passlib")
(version "1.6.5") (version "1.7.0")
(source (source
(origin (origin
(method url-fetch) (method url-fetch)
(uri (pypi-uri "passlib" version)) (uri (pypi-uri "passlib" version))
(sha256 (sha256
(base32 (base32
"1z27wdxs5rj5xhhqfzvzn3yg682irkxw6dcs5jj7mcf97psk8gd8")))) "1vdbqsa1a31s98fxkinl052q8nnpvbxnb83qanxfpi2p6c2zdr0b"))))
(build-system python-build-system) (build-system python-build-system)
(native-inputs (native-inputs
`(("python-nose" ,python-nose) `(("python-nose" ,python-nose)
@ -1180,14 +1181,14 @@ after Andy Lesters Perl module WWW::Mechanize.")
(define-public python-simplejson (define-public python-simplejson
(package (package
(name "python-simplejson") (name "python-simplejson")
(version "3.8.2") (version "3.10.0")
(source (source
(origin (origin
(method url-fetch) (method url-fetch)
(uri (pypi-uri "simplejson" version)) (uri (pypi-uri "simplejson" version))
(sha256 (sha256
(base32 (base32
"0zylrnax8b6r0ndgni4w9c599fi6wm9vx5g6k3ddqfj3932kk16m")))) "1qhwsykjlb85igb4cfl6v6gkprzbbg8gyqdd7zscc8w3x0ifcfwm"))))
(build-system python-build-system) (build-system python-build-system)
(home-page "http://simplejson.readthedocs.org/en/latest/") (home-page "http://simplejson.readthedocs.org/en/latest/")
(synopsis (synopsis
@ -1426,6 +1427,31 @@ backported for previous versions of Python from 2.4 to 3.3.")
syntax.") syntax.")
(license license:x11))) (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 (define-public scons
(package (package
@ -6697,14 +6723,14 @@ message digests and key derivation functions.")
(define-public python-pyopenssl (define-public python-pyopenssl
(package (package
(name "python-pyopenssl") (name "python-pyopenssl")
(version "16.1.0") (version "16.2.0")
(source (source
(origin (origin
(method url-fetch) (method url-fetch)
(uri (pypi-uri "pyOpenSSL" version)) (uri (pypi-uri "pyOpenSSL" version))
(sha256 (sha256
(base32 (base32
"0prm06zz7hl6bk5s2lqzw25lq6smayfv2fgiliw2rbqxlyiavxw8")))) "0vji4yrfshs15xpczbhzhasnjrwcarsqg87n98ixnyafnyxs6ybp"))))
(build-system python-build-system) (build-system python-build-system)
(propagated-inputs (propagated-inputs
`(("python-cryptography" ,python-cryptography) `(("python-cryptography" ,python-cryptography)
@ -9532,18 +9558,20 @@ useful for solving the Assignment Problem.")
(define-public python-flask (define-public python-flask
(package (package
(name "python-flask") (name "python-flask")
(version "0.10.1") (version "0.11.1")
(source (origin (source (origin
(method url-fetch) (method url-fetch)
(uri (pypi-uri "Flask" version)) (uri (pypi-uri "Flask" version))
(sha256 (sha256
(base32 (base32
"0wrkavjdjndknhp8ya8j850jq7a1cli4g5a93mg8nh1xz2gq50sc")))) "03kbfll4sj3v5z7r31c7bhfpi11r1np076d4p1k2kg4yzcmkywdl"))))
(build-system python-build-system) (build-system python-build-system)
(propagated-inputs (propagated-inputs
`(("python-itsdangerous" ,python-itsdangerous) `(("python-itsdangerous" ,python-itsdangerous)
("python-jinja2" ,python-jinja2) ("python-jinja2" ,python-jinja2)
("python-werkzeug" ,python-werkzeug))) ("python-werkzeug" ,python-werkzeug)))
(native-inputs
`(("python-click" ,python-click)))
(home-page "https://github.com/mitsuhiko/flask/") (home-page "https://github.com/mitsuhiko/flask/")
(synopsis "Microframework based on Werkzeug, Jinja2 and good intentions") (synopsis "Microframework based on Werkzeug, Jinja2 and good intentions")
(description "Flask is a micro web framework based on the Werkzeug toolkit (description "Flask is a micro web framework based on the Werkzeug toolkit

View File

@ -119,7 +119,7 @@
(let ((infodir (string-append out "/share/info"))) (let ((infodir (string-append out "/share/info")))
(for-each (lambda (info) (for-each (lambda (info)
(install-file info infodir)) (install-file info infodir))
(find-files "." "\\.info$")) (find-files "." "\\.info"))
#t)))))) #t))))))
(add-before 'check 'make-gtester-verbose (add-before 'check 'make-gtester-verbose
(lambda _ (lambda _

View File

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

View File

@ -5,6 +5,7 @@
;;; Copyright © 2015 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2015 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2016 Lukas Gradl <lgradl@openmailbox.org> ;;; Copyright © 2016 Lukas Gradl <lgradl@openmailbox.org>
;;; Copyright © 2016 Francesco Frassinelli <fraph24@gmail.com> ;;; Copyright © 2016 Francesco Frassinelli <fraph24@gmail.com>
;;; Copyright © 2016 ng0 <ng0@libertad.pw>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -24,13 +25,20 @@
(define-module (gnu packages telephony) (define-module (gnu packages telephony)
#:use-module (gnu packages) #:use-module (gnu packages)
#:use-module (gnu packages autotools) #: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 gnupg)
#:use-module (gnu packages linux) #:use-module (gnu packages linux)
#:use-module (gnu packages multiprecision) #:use-module (gnu packages multiprecision)
#:use-module (gnu packages ncurses) #:use-module (gnu packages ncurses)
#:use-module (gnu packages pkg-config) #: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 tls)
#:use-module (gnu packages xiph) #:use-module (gnu packages xiph)
#:use-module (gnu packages xorg)
#:use-module ((guix licenses) #:prefix license:) #:use-module ((guix licenses) #:prefix license:)
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix download) #: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.") address of one of the participants.")
(home-page "http://holdenc.altervista.org/seren/") (home-page "http://holdenc.altervista.org/seren/")
(license license:gpl3+))) (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))))

View File

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in> ;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in>
;;; Copyright © 2016 Tobias Geerinckx-Rice <me@tobias.gr>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -27,7 +28,7 @@
(define-public miniupnpc (define-public miniupnpc
(package (package
(name "miniupnpc") (name "miniupnpc")
(version "1.9") (version "2.0")
(source (source
(origin (origin
(method url-fetch) (method url-fetch)
@ -35,7 +36,7 @@
"http://miniupnp.tuxfamily.org/files/miniupnpc-" "http://miniupnp.tuxfamily.org/files/miniupnpc-"
version ".tar.gz")) version ".tar.gz"))
(sha256 (sha256
(base32 "0r24jdqcyf839n30ppimdna0hvybscyziaad7ng99fw0x19y88r9")))) (base32 "0fzrc6fs8vzb2yvk01bd3q5jkarysl7gjlyaqncy3yvfk2wcwd6l"))))
(build-system gnu-build-system) (build-system gnu-build-system)
(native-inputs (native-inputs
`(("python" ,python-2))) `(("python" ,python-2)))
@ -54,14 +55,22 @@
(string-append "LDFLAGS=-Wl,-rpath=" (string-append "LDFLAGS=-Wl,-rpath="
(assoc-ref %outputs "out") "/lib")) (assoc-ref %outputs "out") "/lib"))
#:phases #: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/") (home-page "http://miniupnp.free.fr/")
(synopsis "Library implementing the client side UPnP protocol") (synopsis "UPnP protocol client library")
(description (description
"MiniUPnPc is a library is useful whenever an application needs to listen "The MiniUPnPc client library facilitates access to the services provided
for incoming connections but is run behind a UPnP enabled router or firewall. by any Universal Plug and Play (UPnP) Internet Gateway Device (IGD) present on
Examples for such applications include: P2P applications, FTP clients for the network. In UPnP terminology, MiniUPnPc is a UPnP Control Point. It is
active mode, IRC (for DCC) or IM applications, network games, any server useful whenever an application needs to listen for incoming connections while
software.") 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 (license
(x11-style "file://LICENSE" "See 'LICENSE' file in the distribution")))) (x11-style "file://LICENSE" "See 'LICENSE' file in the distribution"))))

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 (define-public ffmpeg
(package (package
(name "ffmpeg") (name "ffmpeg")
(version "3.2") (version "3.2.1")
(source (origin (source (origin
(method url-fetch) (method url-fetch)
(uri (string-append "https://ffmpeg.org/releases/ffmpeg-" (uri (string-append "https://ffmpeg.org/releases/ffmpeg-"
version ".tar.xz")) version ".tar.xz"))
(sha256 (sha256
(base32 (base32
"1nnmd3h9pr2zic08isjcm1cmvcyd0aimpayb9r4qy45bihdhrxw8")))) "1pxsy9s9n2nvz970rid3j3b45w6s7ziwnrbc16rny7k0bpd97kqy"))))
(build-system gnu-build-system) (build-system gnu-build-system)
(inputs (inputs
`(("fontconfig" ,fontconfig) `(("fontconfig" ,fontconfig)

View File

@ -49,7 +49,7 @@
(define-public vim (define-public vim
(package (package
(name "vim") (name "vim")
(version "8.0.0095") (version "8.0.0101")
(source (origin (source (origin
(method url-fetch) (method url-fetch)
(uri (string-append "https://github.com/vim/vim/archive/v" (uri (string-append "https://github.com/vim/vim/archive/v"
@ -57,7 +57,7 @@
(file-name (string-append name "-" version ".tar.gz")) (file-name (string-append name "-" version ".tar.gz"))
(sha256 (sha256
(base32 (base32
"1whib2zzqdpgfhpr7ymqxj3das6iyiapvx0izw4147mkg9yanmp7")))) "0kzk1p5vnqr8j5jwb3p745zx3dki5jwlsp7rh6nli0ci2w6vg3r8"))))
(build-system gnu-build-system) (build-system gnu-build-system)
(arguments (arguments
`(#:test-target "test" `(#:test-target "test"

View File

@ -123,14 +123,14 @@ and its related documentation.")
(define-public nginx (define-public nginx
(package (package
(name "nginx") (name "nginx")
(version "1.11.4") (version "1.11.6")
(source (origin (source (origin
(method url-fetch) (method url-fetch)
(uri (string-append "https://nginx.org/download/nginx-" (uri (string-append "https://nginx.org/download/nginx-"
version ".tar.gz")) version ".tar.gz"))
(sha256 (sha256
(base32 (base32
"0fvb09ycxz3xnyynav6ybj6miwh9kv8jcb2vzrmvqhzn8cgiq8h6")))) "1gc5phrzm2hbpvryaya6rlvasa00vjips4hv5q1rqbcfa6xsnlri"))))
(build-system gnu-build-system) (build-system gnu-build-system)
(inputs `(("pcre" ,pcre) (inputs `(("pcre" ,pcre)
("openssl" ,openssl) ("openssl" ,openssl)
@ -150,7 +150,6 @@ and its related documentation.")
(list (string-append "--prefix=" (assoc-ref outputs "out")) (list (string-append "--prefix=" (assoc-ref outputs "out"))
"--with-http_ssl_module" "--with-http_ssl_module"
"--with-pcre-jit" "--with-pcre-jit"
"--with-ipv6"
"--with-debug" "--with-debug"
;; Even when not cross-building, we pass the ;; Even when not cross-building, we pass the
;; --crossbuild option to avoid customizing for the ;; --crossbuild option to avoid customizing for the

View File

@ -1,6 +1,8 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com> ;;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net> ;;; 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. ;;; This file is part of GNU Guix.
;;; ;;;
@ -22,6 +24,7 @@
#:use-module (guix download) #:use-module (guix download)
#:use-module ((guix licenses) #:prefix l:) #:use-module ((guix licenses) #:prefix l:)
#:use-module (guix build-system glib-or-gtk) #:use-module (guix build-system glib-or-gtk)
#:use-module (guix build-system python)
#:use-module (guix build utils) #:use-module (guix build utils)
#:use-module (gnu packages) #:use-module (gnu packages)
#:use-module (gnu packages compression) #:use-module (gnu packages compression)
@ -31,6 +34,7 @@
#:use-module (gnu packages gtk) #:use-module (gnu packages gtk)
#:use-module (gnu packages image) #:use-module (gnu packages image)
#:use-module (gnu packages pkg-config) #:use-module (gnu packages pkg-config)
#:use-module (gnu packages python)
#:use-module (gnu packages sdl) #:use-module (gnu packages sdl)
#:use-module (gnu packages webkit) #:use-module (gnu packages webkit)
#:use-module (gnu packages xorg)) #:use-module (gnu packages xorg))
@ -109,3 +113,80 @@ and many other languages.")
(assoc-ref %outputs "out") "/lib")) (assoc-ref %outputs "out") "/lib"))
;; No 'check' target. ;; No 'check' target.
#:tests? #f)))) #: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))))

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

View File

@ -19,6 +19,7 @@
(define-module (gnu services cups) (define-module (gnu services cups)
#:use-module (gnu services) #:use-module (gnu services)
#:use-module (gnu services shepherd) #:use-module (gnu services shepherd)
#:use-module (gnu services configuration)
#:use-module (gnu system shadow) #:use-module (gnu system shadow)
#:use-module (gnu packages admin) #:use-module (gnu packages admin)
#:use-module (gnu packages cups) #:use-module (gnu packages cups)
@ -26,16 +27,9 @@
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix records) #:use-module (guix records)
#:use-module (guix gexp) #:use-module (guix gexp)
#:use-module (texinfo)
#:use-module (texinfo serialize)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module ((srfi srfi-1) #:select (append-map)) #:use-module ((srfi srfi-1) #:select (append-map))
#:use-module (srfi srfi-34) #:export (cups-service-type
#:use-module (srfi srfi-35)
#:export (&cups-configuation-error
cups-configuration-error?
cups-service-type
cups-configuration cups-configuration
opaque-cups-configuration opaque-cups-configuration
@ -51,91 +45,6 @@
;;; ;;;
;;; Code: ;;; 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 (define %cups-accounts
(list (user-group (name "lp") (system? #t)) (list (user-group (name "lp") (system? #t))
(user-group (name "lpadmin") (system? #t)) (user-group (name "lpadmin") (system? #t))
@ -147,24 +56,6 @@
(home-directory "/var/empty") (home-directory "/var/empty")
(shell (file-append shadow "/sbin/nologin"))))) (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) (define (multiline-string-list? val)
(and (list? val) (and (list? val)
(and-map (lambda (x) (and-map (lambda (x)
@ -173,28 +64,11 @@
(define (serialize-multiline-string-list field-name val) (define (serialize-multiline-string-list field-name val)
(for-each (lambda (str) (serialize-field field-name str)) 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) (define (space-separated-symbol-list? val)
(and (list? val) (and-map symbol? val))) (and (list? val) (and-map symbol? val)))
(define (serialize-space-separated-symbol-list field-name val) (define (serialize-space-separated-symbol-list field-name val)
(serialize-field field-name (string-join (map symbol->string 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) (define (non-negative-integer? val)
(and (exact-integer? val) (not (negative? val)))) (and (exact-integer? val) (not (negative? val))))
(define (serialize-non-negative-integer field-name 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 (define-configuration location-access-control
(path (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.") "Specifies the URI path to which the access control applies.")
(access-controls (access-controls
(access-control-list '()) (access-control-list '())
@ -359,7 +233,7 @@ methods. Otherwise apply to only the listed methods.")
(define-configuration policy-configuration (define-configuration policy-configuration
(name (name
(string (cups-configuration-missing-field 'policy-configuration 'name)) (string (configuration-missing-field 'policy-configuration 'name))
"Name of the policy.") "Name of the policy.")
(job-private-access (job-private-access
(string "@OWNER @SYSTEM") (string "@OWNER @SYSTEM")
@ -925,12 +799,12 @@ IPP specifications.")
(package-list '()) (package-list '())
"Drivers and other extensions to the CUPS package.") "Drivers and other extensions to the CUPS package.")
(cupsd.conf (cupsd.conf
(string (cups-configuration-missing-field 'opaque-cups-configuration (string (configuration-missing-field 'opaque-cups-configuration
'cupsd.conf)) 'cupsd.conf))
"The contents of the @code{cupsd.conf} to use.") "The contents of the @code{cupsd.conf} to use.")
(cups-files.conf (cups-files.conf
(string (cups-configuration-missing-field 'opaque-cups-configuration (string (configuration-missing-field 'opaque-cups-configuration
'cups-files.conf)) 'cups-files.conf))
"The contents of the @code{cups-files.conf} to use.")) "The contents of the @code{cups-files.conf} to use."))
(define %cups-activation (define %cups-activation
@ -1117,8 +991,8 @@ extensions that it uses."
extensions))))))))) extensions)))))))))
;; A little helper to make it easier to document all those fields. ;; A little helper to make it easier to document all those fields.
(define (generate-documentation) (define (generate-cups-documentation)
(define documentation (generate-documentation
`((cups-configuration `((cups-configuration
,cups-configuration-fields ,cups-configuration-fields
(files-configuration files-configuration) (files-configuration files-configuration)
@ -1132,35 +1006,5 @@ extensions that it uses."
,location-access-control-fields ,location-access-control-fields
(method-access-controls method-access-controls)) (method-access-controls method-access-controls))
(operation-access-controls ,operation-access-control-fields) (operation-access-controls ,operation-access-control-fields)
(method-access-controls ,method-access-control-fields))) (method-access-controls ,method-access-control-fields))
(define (str x) (object->string x)) 'cups-configuration))
(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))))

View File

@ -21,7 +21,9 @@
#:use-module (gnu services) #:use-module (gnu services)
#:use-module (gnu services shepherd) #:use-module (gnu services shepherd)
#:use-module (gnu system shadow) #:use-module (gnu system shadow)
#:use-module (gnu system pam)
#:use-module ((gnu packages glib) #:select (dbus)) #:use-module ((gnu packages glib) #:select (dbus))
#:use-module (gnu packages polkit)
#:use-module (gnu packages admin) #:use-module (gnu packages admin)
#:use-module (guix gexp) #:use-module (guix gexp)
#:use-module (guix records) #:use-module (guix records)
@ -30,7 +32,10 @@
#:export (dbus-configuration #:export (dbus-configuration
dbus-configuration? dbus-configuration?
dbus-root-service-type dbus-root-service-type
dbus-service)) dbus-service
polkit-service-type
polkit-service))
;;; ;;;
;;; D-Bus. ;;; D-Bus.
@ -218,4 +223,91 @@ and policy files. For example, to allow avahi-daemon to use the system bus,
(dbus-configuration (dbus dbus) (dbus-configuration (dbus dbus)
(services services)))) (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 ;;; dbus.scm ends here

View File

@ -37,7 +37,6 @@
#:use-module (gnu packages gnome) #:use-module (gnu packages gnome)
#:use-module (gnu packages xfce) #:use-module (gnu packages xfce)
#:use-module (gnu packages avahi) #:use-module (gnu packages avahi)
#:use-module (gnu packages polkit)
#:use-module (gnu packages xdisorg) #:use-module (gnu packages xdisorg)
#:use-module (gnu packages suckless) #:use-module (gnu packages suckless)
#:use-module (gnu packages linux) #:use-module (gnu packages linux)
@ -68,11 +67,6 @@
bluetooth-service bluetooth-service
polkit-configuration
polkit-configuration?
polkit-service
polkit-service-type
elogind-configuration elogind-configuration
elogind-configuration? elogind-configuration?
elogind-service 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)) (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. ;;; Colord D-Bus service.

View File

@ -38,15 +38,17 @@
"Return a PAM service for Kerberos authentication." "Return a PAM service for Kerberos authentication."
(lambda (pam) (lambda (pam)
(define pam-krb5-module (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 (let ((pam-krb5-sufficient
(pam-entry (pam-entry
(control "sufficient") (control "sufficient")
(module pam-krb5-module) (module pam-krb5-module)
(arguments (list (arguments
(format #f "minimum_uid=~a" (list
(pam-krb5-configuration-minimum-uid config))))))) (format #f "minimum_uid=~a"
(pam-krb5-configuration-minimum-uid config)))))))
(pam-service (pam-service
(inherit pam) (inherit pam)
(auth (cons* pam-krb5-sufficient (auth (cons* pam-krb5-sufficient

View File

@ -21,6 +21,7 @@
(define-module (gnu services mail) (define-module (gnu services mail)
#:use-module (gnu services) #:use-module (gnu services)
#:use-module (gnu services base) #:use-module (gnu services base)
#:use-module (gnu services configuration)
#:use-module (gnu services shepherd) #:use-module (gnu services shepherd)
#:use-module (gnu system pam) #:use-module (gnu system pam)
#:use-module (gnu system shadow) #:use-module (gnu system shadow)
@ -30,13 +31,8 @@
#:use-module (guix records) #:use-module (guix records)
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix gexp) #:use-module (guix gexp)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:export (&dovecot-configuation-error #:export (dovecot-service
dovecot-configuration-error?
dovecot-service
dovecot-service-type dovecot-service-type
dovecot-configuration dovecot-configuration
opaque-dovecot-configuration opaque-dovecot-configuration
@ -51,7 +47,12 @@
protocol-configuration protocol-configuration
plugin-configuration plugin-configuration
mailbox-configuration mailbox-configuration
namespace-configuration)) namespace-configuration
opensmtpd-configuration
opensmtpd-configuration?
opensmtpd-service-type
%default-opensmtpd-config-file))
;;; Commentary: ;;; Commentary:
;;; ;;;
@ -60,112 +61,6 @@
;;; ;;;
;;; Code: ;;; 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) (define (comma-separated-string-list? val)
(and (list? val) (and (list? val)
@ -175,12 +70,6 @@
(define (serialize-comma-separated-string-list field-name val) (define (serialize-comma-separated-string-list field-name val)
(serialize-field field-name (string-join 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) (define (colon-separated-file-name-list? val)
(and (list? val) (and (list? val)
;; Trailing slashes not needed and not ;; Trailing slashes not needed and not
@ -188,9 +77,6 @@
(define (serialize-colon-separated-file-name-list field-name val) (define (serialize-colon-separated-file-name-list field-name val)
(serialize-field field-name (string-join 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) (define (non-negative-integer? val)
(and (exact-integer? val) (not (negative? val)))) (and (exact-integer? val) (not (negative? val))))
(define (serialize-non-negative-integer field-name val) (define (serialize-non-negative-integer field-name val)
@ -271,7 +157,7 @@
(define-configuration unix-listener-configuration (define-configuration unix-listener-configuration
(path (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.") "The file name on which to listen.")
(mode (mode
(string "0600") (string "0600")
@ -290,7 +176,7 @@
(define-configuration fifo-listener-configuration (define-configuration fifo-listener-configuration
(path (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.") "The file name on which to listen.")
(mode (mode
(string "0600") (string "0600")
@ -309,14 +195,14 @@
(define-configuration inet-listener-configuration (define-configuration inet-listener-configuration
(protocol (protocol
(string (dovecot-configuration-missing-field 'inet-listener 'protocol)) (string (configuration-missing-field 'inet-listener 'protocol))
"The protocol to listen for.") "The protocol to listen for.")
(address (address
(string "") (string "")
"The address on which to listen, or empty for all addresses.") "The address on which to listen, or empty for all addresses.")
(port (port
(non-negative-integer (non-negative-integer
(dovecot-configuration-missing-field 'inet-listener 'port)) (configuration-missing-field 'inet-listener 'port))
"The port on which to listen.") "The port on which to listen.")
(ssl? (ssl?
(boolean #t) (boolean #t)
@ -340,7 +226,7 @@
(serialize-fifo-listener-configuration field-name val)) (serialize-fifo-listener-configuration field-name val))
((inet-listener-configuration? val) ((inet-listener-configuration? val)
(serialize-inet-listener-configuration field-name 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) (define (listener-configuration-list? val)
(and (list? val) (and-map listener-configuration? val))) (and (list? val) (and-map listener-configuration? val)))
(define (serialize-listener-configuration-list field-name val) (define (serialize-listener-configuration-list field-name val)
@ -350,7 +236,7 @@
(define-configuration service-configuration (define-configuration service-configuration
(kind (kind
(string (dovecot-configuration-missing-field 'service 'kind)) (string (configuration-missing-field 'service 'kind))
"The service kind. Valid values include @code{director}, "The service kind. Valid values include @code{director},
@code{imap-login}, @code{pop3-login}, @code{lmtp}, @code{imap}, @code{imap-login}, @code{pop3-login}, @code{lmtp}, @code{imap},
@code{pop3}, @code{auth}, @code{auth-worker}, @code{dict}, @code{pop3}, @code{auth}, @code{auth-worker}, @code{dict},
@ -388,7 +274,7 @@ this."))
(define-configuration protocol-configuration (define-configuration protocol-configuration
(name (name
(string (dovecot-configuration-missing-field 'protocol 'name)) (string (configuration-missing-field 'protocol 'name))
"The name of the protocol.") "The name of the protocol.")
(auth-socket-path (auth-socket-path
(string "/var/run/dovecot/auth-userdb") (string "/var/run/dovecot/auth-userdb")
@ -1492,8 +1378,8 @@ greyed out, instead of only later giving \"not selectable\" popup error.
"The dovecot package.") "The dovecot package.")
(string (string
(string (dovecot-configuration-missing-field 'opaque-dovecot-configuration (string (configuration-missing-field 'opaque-dovecot-configuration
'string)) 'string))
"The contents of the @code{dovecot.conf} to use.")) "The contents of the @code{dovecot.conf} to use."))
(define %dovecot-accounts (define %dovecot-accounts
@ -1629,8 +1515,8 @@ by @code{dovecot-configuration}. @var{config} may also be created by
(service dovecot-service-type config)) (service dovecot-service-type config))
;; A little helper to make it easier to document all those fields. ;; A little helper to make it easier to document all those fields.
(define (generate-documentation) (define (generate-dovecot-documentation)
(define documentation (generate-documentation
`((dovecot-configuration `((dovecot-configuration
,dovecot-configuration-fields ,dovecot-configuration-fields
(dict dict-configuration) (dict dict-configuration)
@ -1655,39 +1541,80 @@ by @code{dovecot-configuration}. @var{config} may also be created by
,service-configuration-fields ,service-configuration-fields
(listeners unix-listener-configuration fifo-listener-configuration (listeners unix-listener-configuration fifo-listener-configuration
inet-listener-configuration)) inet-listener-configuration))
(protocol-configuration ,protocol-configuration-fields))) (protocol-configuration ,protocol-configuration-fields))
(define (generate configuration-name) 'dovecot-configuration))
(match (assq-ref documentation configuration-name)
((fields . sub-documentation)
(format #t "\nAvailable @code{~a} fields are:\n\n" configuration-name) ;;;
(for-each ;;; OpenSMTPD.
(lambda (f) ;;;
(let ((field-name (configuration-field-name f))
(field-type (configuration-field-type f)) (define-record-type* <opensmtpd-configuration>
(field-docs (string-trim-both opensmtpd-configuration make-opensmtpd-configuration
(configuration-field-documentation f))) opensmtpd-configuration?
(default (catch #t (package opensmtpd-configuration-package
(configuration-field-default-value-thunk f) (default opensmtpd))
(lambda _ 'nope)))) (config-file opensmtpd-configuration-config-file
(define (escape-chars str chars escape) (default %default-opensmtpd-config-file)))
(with-output-to-string
(lambda () (define %default-opensmtpd-config-file
(string-for-each (lambda (c) (plain-file "smtpd.conf" "
(when (char-set-contains? chars c) listen on lo
(display escape)) accept from any for local deliver to mbox
(display c)) accept from local for any relay
str)))) "))
(define (show-default? val)
(or (string? default) (number? default) (boolean? default) (define opensmtpd-shepherd-service
(and (list? val) (and-map show-default? val)))) (match-lambda
(format #t "@deftypevr {@code{~a} parameter} ~a ~a\n~a\n" (($ <opensmtpd-configuration> package config-file)
configuration-name field-type field-name field-docs) (list (shepherd-service
(when (show-default? default) (provision '(smtpd))
(format #t "Defaults to @samp{~a}.\n" (requirement '(loopback))
(escape-chars (format #f "~s" default) (documentation "Run the OpenSMTPD daemon.")
(char-set #\@ #\{ #\}) (start (let ((smtpd (file-append package "/sbin/smtpd")))
#\@))) #~(make-forkexec-constructor
(for-each generate (or (assq-ref sub-documentation field-name) '())) (list #$smtpd "-f" #$config-file)
(format #t "@end deftypevr\n\n"))) #:pid-file "/var/run/smtpd.pid")))
fields)))) (stop #~(make-kill-destructor)))))))
(generate 'dovecot-configuration))
(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)))))

View File

@ -682,7 +682,7 @@ and @command{wicd-curses} user interfaces."
(list (shepherd-service (list (shepherd-service
(documentation "Run the NetworkManager.") (documentation "Run the NetworkManager.")
(provision '(networking)) (provision '(networking))
(requirement '(user-processes dbus-system loopback)) (requirement '(user-processes dbus-system wpa-supplicant loopback))
(start #~(make-forkexec-constructor (start #~(make-forkexec-constructor
(list (string-append #$network-manager (list (string-append #$network-manager
"/sbin/NetworkManager") "/sbin/NetworkManager")
@ -695,6 +695,7 @@ and @command{wicd-curses} user interfaces."
(list (service-extension shepherd-root-service-type (list (service-extension shepherd-root-service-type
network-manager-shepherd-service) network-manager-shepherd-service)
(service-extension dbus-root-service-type list) (service-extension dbus-root-service-type list)
(service-extension polkit-service-type list)
(service-extension activation-service-type (service-extension activation-service-type
(const %network-manager-activation)) (const %network-manager-activation))
;; Add network-manager to the system profile. ;; Add network-manager to the system profile.

View File

@ -1,5 +1,6 @@
;; This is an operating system configuration template ;; 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-modules (gnu) (gnu system nss))
(use-service-modules desktop) (use-service-modules desktop)
@ -13,11 +14,21 @@
;; Assuming /dev/sdX is the target hard disk, and "my-root" ;; Assuming /dev/sdX is the target hard disk, and "my-root"
;; is the label of the target root file system. ;; is the label of the target root file system.
(bootloader (grub-configuration (device "/dev/sdX"))) (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 (file-systems (cons (file-system
(device "my-root") (device "my-root")
(title 'label) (title 'label)
(mount-point "/") (mount-point "/")
(type "ext4")) (type "ext4")
(dependencies mapped-devices))
%base-file-systems)) %base-file-systems))
(users (cons (user-account (users (cons (user-account

View File

@ -23,7 +23,7 @@
#:use-module (guix modules) #:use-module (guix modules)
#:use-module (gnu services) #:use-module (gnu services)
#:use-module (gnu services shepherd) #:use-module (gnu services shepherd)
#:autoload (gnu packages cryptsetup) (cryptsetup) #:autoload (gnu packages cryptsetup) (cryptsetup-static)
#:autoload (gnu packages linux) (mdadm-static) #:autoload (gnu packages linux) (mdadm-static)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (ice-9 match) #:use-module (ice-9 match)
@ -104,7 +104,9 @@
((gnu build file-systems) ((gnu build file-systems)
#:select (find-partition-by-luks-uuid))) #: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" "open" "--type" "luks"
;; Note: We cannot use the "UUID=source" syntax here ;; Note: We cannot use the "UUID=source" syntax here
@ -120,7 +122,7 @@
(define (close-luks-device source target) (define (close-luks-device source target)
"Return a gexp that closes TARGET, a LUKS device." "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))) "close" #$target)))
(define luks-device-mapping (define luks-device-mapping

View File

@ -31,6 +31,8 @@
#:use-module (gnu services mcron) #:use-module (gnu services mcron)
#:use-module (gnu services shepherd) #:use-module (gnu services shepherd)
#:use-module (gnu services networking) #:use-module (gnu services networking)
#:use-module (gnu packages imagemagick)
#:use-module (gnu packages ocr)
#:use-module (guix gexp) #:use-module (guix gexp)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix monads) #:use-module (guix monads)
@ -65,10 +67,16 @@
%base-user-accounts)))) %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 "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 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 (define test
(with-imported-modules '((gnu build marionette)) (with-imported-modules '((gnu build marionette))
#~(begin #~(begin
@ -86,6 +94,9 @@ properties of running system to what's declared in OS, an <operating-system>."
(test-begin "basic") (test-begin "basic")
#$(and initialization
(initialization #~marionette))
(test-assert "uname" (test-assert "uname"
(match (marionette-eval '(uname) marionette) (match (marionette-eval '(uname) marionette)
(#("Linux" host-name version _ architecture) (#("Linux" host-name version _ architecture)
@ -188,14 +199,8 @@ info --version")
(test-equal "locale" (test-equal "locale"
"en_US.utf8" "en_US.utf8"
(marionette-eval '(begin (marionette-eval '(let ((before (setlocale LC_ALL "en_US.utf8")))
;; XXX: This 'setenv' call wouldn't be needed (setlocale LC_ALL before))
;; 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)) marionette))
(test-assert "/run/current-system is a GC root" (test-assert "/run/current-system is a GC root"
@ -241,6 +246,20 @@ info --version")
marionette) marionette)
(file-exists? "tty1.ppm"))) (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) (test-end)
(exit (= (test-runner-fail-count (test-runner-current)) 0))))) (exit (= (test-runner-fail-count (test-runner-current)) 0)))))

View File

@ -24,6 +24,7 @@
#:use-module (gnu system install) #:use-module (gnu system install)
#:use-module (gnu system vm) #:use-module (gnu system vm)
#:use-module ((gnu build vm) #:select (qemu-command)) #:use-module ((gnu build vm) #:select (qemu-command))
#:use-module (gnu packages ocr)
#:use-module (gnu packages qemu) #:use-module (gnu packages qemu)
#:use-module (gnu packages package-management) #:use-module (gnu packages package-management)
#:use-module (guix store) #:use-module (guix store)
@ -398,17 +399,20 @@ by 'mdadm'.")
(locale "en_US.UTF-8") (locale "en_US.UTF-8")
(bootloader (grub-configuration (device "/dev/vdb"))) (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 (file-systems (cons (file-system
(device "/dev/mapper/the-root-device") (device "/dev/mapper/the-root-device")
(title 'device) (title 'device)
(mount-point "/") (mount-point "/")
(type "ext4")) (type "ext4"))
%base-file-systems)) %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 (users (cons (user-account
(name "charlie") (name "charlie")
(group "users") (group "users")
@ -435,7 +439,8 @@ parted --script /dev/vdb mklabel gpt \\
mkpart primary ext2 3M 1G \\ mkpart primary ext2 3M 1G \\
set 1 boot on \\ set 1 boot on \\
set 1 bios_grub 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 | \\ echo -n thepassphrase | \\
cryptsetup open --type luks --key-file - /dev/vdb2 the-root-device cryptsetup open --type luks --key-file - /dev/vdb2 the-root-device
mkfs.ext4 -L my-root /dev/mapper/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 herd start cow-store /mnt
mkdir /mnt/etc mkdir /mnt/etc
cp /etc/target-config.scm /mnt/etc/config.scm 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 build /mnt/etc/config.scm
guix system init /mnt/etc/config.scm /mnt --no-substitutes guix system init /mnt/etc/config.scm /mnt --no-substitutes
sync sync
reboot\n") 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 (define %test-encrypted-os
(system-test (system-test
(name "encrypted-root-os") (name "encrypted-root-os")
@ -465,6 +508,7 @@ build (current-guix) and then store a couple of full system images.")
#:script #:script
%encrypted-root-installation-script)) %encrypted-root-installation-script))
(command (qemu-command/writable-image image))) (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 ;;; install.scm ends here

View File

@ -17,6 +17,13 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix scripts offload) (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 config)
#:use-module (guix records) #:use-module (guix records)
#:use-module (guix store) #:use-module (guix store)
@ -65,14 +72,15 @@
(system build-machine-system) ; string (system build-machine-system) ; string
(user build-machine-user) ; string (user build-machine-user) ; string
(private-key build-machine-private-key ; file name (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 (parallel-builds build-machine-parallel-builds ; number
(default 1)) (default 1))
(speed build-machine-speed ; inexact real (speed build-machine-speed ; inexact real
(default 1.0)) (default 1.0))
(features build-machine-features ; list of strings (features build-machine-features ; list of strings
(default '()))
(ssh-options build-machine-ssh-options ; list of strings
(default '()))) (default '())))
(define-record-type* <build-requirements> (define-record-type* <build-requirements>
@ -86,19 +94,11 @@
;; File that lists machines available as build slaves. ;; File that lists machines available as build slaves.
(string-append %config-directory "/machines.scm")) (string-append %config-directory "/machines.scm"))
(define %lsh-command (define (user-openssh-private-key)
"lsh") "Return the user's default SSH private key, or #f if it could not be
(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
determined." determined."
(and=> (getenv "HOME") (and=> (getenv "HOME")
(cut string-append <> "/.lsh/identity"))) (cut string-append <> "/.ssh/id_rsa")))
(define %user-module (define %user-module
;; Module in which the machine description file is loaded. ;; Module in which the machine description file is loaded.
@ -134,81 +134,120 @@ determined."
(leave (_ "failed to load machine file '~a': ~s~%") (leave (_ "failed to load machine file '~a': ~s~%")
file args)))))) file args))))))
;;; FIXME: The idea was to open the connection to MACHINE once for all, but (define (host-key->type+key host-key)
;;; lshg is currently non-functional. "Destructure HOST-KEY, an OpenSSH host key string, and return two values:
;; (define (open-ssh-gateway machine) its key type as a symbol, and the actual base64-encoded string."
;; "Initiate an SSH connection gateway to MACHINE, and return the PID of the (define (type->symbol type)
;; running lsh gateway upon success, or #f on failure." (and (string-prefix? "ssh-" type)
;; (catch 'system-error (string->symbol (string-drop type 4))))
;; (lambda ()
;; (let* ((port (open-pipe* OPEN_READ %lsh-command
;; "-l" (build-machine-user machine)
;; "-i" (build-machine-private-key machine)
;; ;; XXX: With lsh 2.1, passing '--write-pid'
;; ;; last causes the PID not to be printed.
;; "--write-pid" "--gateway" "--background"
;; (build-machine-name machine)))
;; (line (read-line port))
;; (status (close-pipe port)))
;; (if (zero? status)
;; (let ((pid (string->number line)))
;; (if (integer? pid)
;; pid
;; (begin
;; (warning (_ "'~a' did not write its PID on stdout: ~s~%")
;; %lsh-command line)
;; #f)))
;; (begin
;; (warning (_ "failed to initiate SSH connection to '~a':\
;; '~a' exited with ~a~%")
;; (build-machine-name machine)
;; %lsh-command
;; (status:exit-val status))
;; #f))))
;; (lambda args
;; (leave (_ "failed to execute '~a': ~a~%")
;; %lsh-command (strerror (system-error-errno args))))))
(define-syntax with-error-to-port (match (string-tokenize host-key)
(syntax-rules () ((type key _)
((_ port exp0 exp ...) (values (type->symbol type) key))
(let ((new port) ((type key)
(old (current-error-port))) (values (type->symbol type) key))))
(dynamic-wind
(lambda ()
(set-current-error-port new))
(lambda ()
exp0 exp ...)
(lambda ()
(set-current-error-port old)))))))
(define* (remote-pipe machine mode command (define (private-key-from-file* file)
#:key (error-port (current-error-port)) (quote? #t)) "Like 'private-key-from-file', but raise an error that 'with-error-handling'
"Run COMMAND (a string list) on MACHINE, assuming an lsh gateway has been can interpret meaningfully."
set up. When QUOTE? is true, perform shell-quotation of all the elements of (catch 'guile-ssh-error
COMMAND. Return either a pipe opened with MODE, or #f if the lsh client could (lambda ()
not be started." (private-key-from-file file))
(define (shell-quote str) (lambda (key proc str . rest)
;; Sort-of shell-quote STR so it can be passed as an argument to the (raise (condition
;; shell. (&message (message (format #f (_ "failed to load SSH \
(with-output-to-string private key from '~a': ~a")
(lambda () file str))))))))
(write str))))
;; Let the child inherit ERROR-PORT. (define (open-ssh-session machine)
(with-error-to-port error-port "Open an SSH session for MACHINE and return it. Throw an error on failure."
(apply open-pipe* mode %lshg-command (let ((private (private-key-from-file* (build-machine-private-key machine)))
"-l" (build-machine-user machine) (public (public-key-from-file
"-p" (number->string (build-machine-port machine)) (string-append (build-machine-private-key machine)
".pub")))
(session (make-session #:user (build-machine-user machine)
#:host (build-machine-name machine)
#:port (build-machine-port machine)
#:timeout 5 ;seconds
;; #:log-verbosity 'protocol
#:identity (build-machine-private-key machine)
;; XXX: Remove '-i' when %LSHG-COMMAND really is lshg. ;; We need lightweight compression when
"-i" (build-machine-private-key machine) ;; exchanging full archives.
#:compression "zlib"
#:compression-level 3)))
(connect! session)
(append (build-machine-ssh-options machine) ;; Authenticate the server. XXX: Guile-SSH 0.10.1 doesn't know about
(list (build-machine-name machine)) ;; ed25519 keys and 'get-key-type' returns #f in that case.
(if quote? (let-values (((server) (get-server-public-key session))
(map shell-quote command) ((type key) (host-key->type+key
command))))) (build-machine-host-key machine))))
(unless (and (or (not (get-key-type server))
(eq? (get-key-type server) type))
(string=? (public-key->string server) key))
;; Key mismatch: something's wrong. XXX: It could be that the server
;; provided its Ed25519 key when we where expecting its RSA key.
(leave (_ "server at '~a' returned host key '~a' of type '~a' \
instead of '~a' of type '~a'~%")
(build-machine-name machine)
(public-key->string server) (get-key-type server)
key type)))
(let ((auth (userauth-public-key! session private)))
(unless (eq? 'success auth)
(disconnect! session)
(leave (_ "SSH public key authentication failed for '~a': ~a~%")
(build-machine-name machine) (get-error session))))
session))
(define* (connect-to-remote-daemon session
#:optional
(socket-name "/var/guix/daemon-socket/socket"))
"Connect to the remote build daemon listening on SOCKET-NAME over SESSION,
an SSH session. Return a <nix-server> object."
(define redirect
;; Code run in SESSION to redirect the remote process' stdin/stdout to the
;; daemon's socket, à la socat. The SSH protocol supports forwarding to
;; Unix-domain sockets but libssh doesn't have an API for that, hence this
;; hack.
`(begin
(use-modules (ice-9 match) (rnrs io ports))
(let ((sock (socket AF_UNIX SOCK_STREAM 0))
(stdin (current-input-port))
(stdout (current-output-port)))
(setvbuf stdin _IONBF)
(setvbuf stdout _IONBF)
(connect sock AF_UNIX ,socket-name)
(let loop ()
(match (select (list stdin sock) '() (list stdin stdout sock))
((reads writes ())
(when (memq stdin reads)
(match (get-bytevector-some stdin)
((? eof-object?)
(primitive-exit 0))
(bv
(put-bytevector sock bv))))
(when (memq sock reads)
(match (get-bytevector-some sock)
((? eof-object?)
(primitive-exit 0))
(bv
(put-bytevector stdout bv))))
(loop))
(_
(primitive-exit 1)))))))
(let ((channel
(open-remote-pipe* session OPEN_BOTH
;; Sort-of shell-quote REDIRECT.
"guile" "-c"
(object->string
(object->string redirect)))))
(open-connection #:port channel)))
;;; ;;;
@ -299,113 +338,6 @@ hook."
(set-port-revealed! port 1) (set-port-revealed! port 1)
port)) 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 (define* (transfer-and-offload drv machine
#:key #:key
(inputs '()) (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 "Offload DRV to MACHINE. Prior to the actual offloading, transfer all of
INPUTS to MACHINE; if building DRV succeeds, retrieve all of OUTPUTS from INPUTS to MACHINE; if building DRV succeeds, retrieve all of OUTPUTS from
MACHINE." MACHINE."
(when (begin (define session
(register-gc-root (derivation-file-name drv) machine) (open-ssh-session machine))
(send-files (cons (derivation-file-name drv) inputs)
machine))
(let ((status (offload drv machine
#:print-build-trace? print-build-trace?
#:max-silent-time max-silent-time
#:build-timeout build-timeout)))
(if (zero? status)
(begin
(retrieve-files outputs machine)
(remove-gc-roots machine)
(format (current-error-port)
"done with offloaded '~a'~%"
(derivation-file-name drv)))
(begin
(remove-gc-roots machine)
(format (current-error-port)
"derivation '~a' offloaded to '~a' failed \
with exit code ~a~%"
(derivation-file-name drv)
(build-machine-name machine)
(status:exit-val status))
;; Use exit code 100 for a permanent build failure. The daemon (define store
;; interprets other non-zero codes as transient build failures. (connect-to-remote-daemon session
(primitive-exit 100)))))) (build-machine-daemon-socket machine)))
(define (send-files files machine) (set-build-options store
"Send the subset of FILES that's missing to MACHINE's store. Return #t on #:print-build-trace print-build-trace?
success, #f otherwise." #:max-silent-time max-silent-time
(define (missing-files files) #:timeout build-timeout)
;; 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)))
;; Protect DRV from garbage collection.
(add-temp-root store (derivation-file-name drv))
(send-files (cons (derivation-file-name drv) inputs)
store)
(format (current-error-port) "offloading '~a' to '~a'...~%"
(derivation-file-name drv) (build-machine-name machine))
(format (current-error-port) "@ build-remote ~a ~a~%"
(derivation-file-name drv) (build-machine-name machine))
(guard (c ((nix-protocol-error? c)
(format (current-error-port)
(_ "derivation '~a' offloaded to '~a' failed: ~a~%")
(derivation-file-name drv)
(build-machine-name machine)
(nix-protocol-error-message c))
;; Use exit code 100 for a permanent build failure. The daemon
;; interprets other non-zero codes as transient build failures.
(primitive-exit 100)))
(build-derivations store (list drv)))
(retrieve-files outputs store)
(format (current-error-port) "done with offloaded '~a'~%"
(derivation-file-name drv)))
(define (store-import-channel session)
"Return an output port to which archives to be exported to SESSION's store
can be written."
;; Using the 'import-paths' RPC on a remote store would be slow because it
;; makes a round trip every time 32 KiB have been transferred. This
;; procedure instead opens a separate channel to use the remote
;; 'import-paths' procedure, which consumes all the data in a single round
;; trip.
(define import
`(begin
(use-modules (guix))
(with-store store
(setvbuf (current-input-port) _IONBF)
(import-paths store (current-input-port)))))
(open-remote-output-pipe session
(string-join
`("guile" "-c"
,(object->string
(object->string import))))))
(define (store-export-channel session files)
"Return an input port from which an export of FILES from SESSION's store can
be read."
;; Same as above: this is more efficient than calling 'export-paths' on a
;; remote store.
(define export
`(begin
(use-modules (guix))
(with-store store
(setvbuf (current-output-port) _IONBF)
(export-paths store ',files (current-output-port)))))
(open-remote-input-pipe session
(string-join
`("guile" "-c"
,(object->string
(object->string export))))))
(define (send-files files remote)
"Send the subset of FILES that's missing to REMOTE, a remote store."
(with-store store (with-store store
(guard (c ((nix-protocol-error? c) ;; Compute the subset of FILES missing on SESSION, and send them in
(warning (_ "failed to export files for '~a': ~s~%") ;; topologically sorted order so that they can actually be imported.
(build-machine-name machine) (let* ((sorted (topologically-sorted store files))
c) (session (channel-get-session (nix-server-socket remote)))
#f)) (node (make-node session))
(missing (node-eval node
`(begin
(use-modules (guix)
(srfi srfi-1) (srfi srfi-26))
;; Compute the subset of FILES missing on MACHINE, and send them in (with-store store
;; topologically sorted order so that they can actually be imported. (remove (cut valid-path? store <>)
;; ',sorted)))))
;; To reduce load on the machine that's offloading (since it's typically (port (store-import-channel session)))
;; already quite busy, see hydra.gnu.org), compress with gzip rather (format #t (_ "sending ~a store files to '~a'...~%")
;; than xz: For a compression ratio 2 times larger, it is 20 times (length missing) (session-get session 'host))
;; faster.
(let* ((files (missing-files (topologically-sorted store files)))
(pipe (remote-pipe machine OPEN_WRITE
'("gzip" "-dc" "|"
"guix" "archive" "--import")
#:quote? #f)))
(format #t (_ "sending ~a store files to '~a'...~%")
(length files) (build-machine-name machine))
(call-with-compressed-output-port 'gzip pipe
(lambda (compressed)
(catch 'system-error
(lambda ()
(export-paths store files compressed))
(lambda args
(warning (_ "failed while exporting files to '~a': ~a~%")
(build-machine-name machine)
(strerror (system-error-errno args))))))
#:options '("--fast"))
;; Wait for the 'lsh' process to complete. (export-paths store missing port)
(zero? (close-pipe pipe))))))
(define (retrieve-files files machine) ;; Tell the remote process that we're done. (In theory the
"Retrieve FILES from MACHINE's store, and import them." ;; end-of-archive mark of 'export-paths' would be enough, but in
(define host ;; practice it's not.)
(build-machine-name machine)) (channel-send-eof port)
(let ((pipe (remote-pipe machine OPEN_READ ;; Wait for completion of the remote process.
`("guix" "archive" "--export" ,@files (let ((result (zero? (channel-get-exit-status port))))
"|" "xz" "-c") (close-port port)
#:quote? #f))) result))))
(and pipe
(with-store store
(guard (c ((nix-protocol-error? c)
(warning (_ "failed to import files from '~a': ~s~%")
host c)
#f))
(format (current-error-port) "retrieving ~a files from '~a'...~%"
(length files) host)
;; We cannot use the 'import-paths' RPC here because we already (define (retrieve-files files remote)
;; hold the locks for FILES. "Retrieve FILES from SESSION's store, and import them."
(call-with-decompressed-port 'xz pipe (let* ((session (channel-get-session (nix-server-socket remote)))
(lambda (decompressed) (host (session-get session 'host))
(restore-file-set decompressed (port (store-export-channel session files)))
#:log-port (current-error-port) (format #t (_ "retrieving ~a files from '~a'...~%")
#:lock? #f))) (length files) host)
;; Wait for the 'lsh' process to complete. ;; We cannot use the 'import-paths' RPC here because we already
(zero? (close-pipe pipe))))))) ;; hold the locks for FILES.
(let ((result (restore-file-set port
#:log-port (current-error-port)
#:lock? #f)))
(close-port port)
result)))
;;; ;;;
@ -547,13 +490,11 @@ success, #f otherwise."
(define (machine-load machine) (define (machine-load machine)
"Return the load of MACHINE, divided by the number of parallel builds "Return the load of MACHINE, divided by the number of parallel builds
allowed on MACHINE." allowed on MACHINE."
(let* ((pipe (remote-pipe machine OPEN_READ `("cat" "/proc/loadavg"))) (let* ((session (open-ssh-session machine))
(line (read-line pipe)) (pipe (open-remote-pipe* session OPEN_READ
(status (close-pipe pipe))) "cat" "/proc/loadavg"))
(unless (eqv? 0 (status:exit-val status)) (line (read-line pipe)))
(warning (_ "failed to obtain load of '~a': SSH client exited with ~a~%") (close-port pipe)
(build-machine-name machine)
(status:exit-val status)))
(if (eof-object? line) (if (eof-object? line)
+inf.0 ;MACHINE does not respond, so assume it is infinitely loaded +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. ;; Not now, all the machines are busy.
(display "# postpone\n"))))))) (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. ;;; Entry point.
@ -716,7 +646,7 @@ defines a total order on machines.)"
(cond ((regexp-exec request-line-rx line) (cond ((regexp-exec request-line-rx line)
=> =>
(lambda (match) (lambda (match)
(with-nar-error-handling (with-error-handling
(process-request (equal? (match:substring match 1) "1") (process-request (equal? (match:substring match 1) "1")
(match:substring match 2) ; system (match:substring match 2) ; system
(call-with-input-file (call-with-input-file

View File

@ -345,50 +345,58 @@
(message nix-protocol-error-message) (message nix-protocol-error-message)
(status nix-protocol-error-status)) (status nix-protocol-error-status))
(define* (open-connection #:optional (file (%daemon-socket-file)) (define (open-unix-domain-socket file)
#:key (reserve-space? #t) cpu-affinity) "Connect to the Unix-domain socket at FILE and return it. Raise a
"Connect to the daemon over the Unix-domain socket at FILE. When '&nix-connection-error' upon error."
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 ((s (with-fluids ((%default-port-encoding #f)) (let ((s (with-fluids ((%default-port-encoding #f))
;; This trick allows use of the `scm_c_read' optimization. ;; This trick allows use of the `scm_c_read' optimization.
(socket PF_UNIX SOCK_STREAM 0))) (socket PF_UNIX SOCK_STREAM 0)))
(a (make-socket-address PF_UNIX file))) (a (make-socket-address PF_UNIX file)))
(catch 'system-error (catch 'system-error
(cut connect s a) (lambda ()
(connect s a)
s)
(lambda args (lambda args
;; Translate the error to something user-friendly. ;; Translate the error to something user-friendly.
(let ((errno (system-error-errno args))) (let ((errno (system-error-errno args)))
(raise (condition (&nix-connection-error (raise (condition (&nix-connection-error
(file file) (file file)
(errno errno))))))) (errno errno)))))))))
(write-int %worker-magic-1 s) (define* (open-connection #:optional (file (%daemon-socket-file))
(let ((r (read-int s))) #: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) (and (eqv? r %worker-magic-2)
(let ((v (read-int s))) (let ((v (read-int port)))
(and (eqv? (protocol-major %protocol-version) (and (eqv? (protocol-major %protocol-version)
(protocol-major v)) (protocol-major v))
(begin (begin
(write-int %protocol-version s) (write-int %protocol-version port)
(when (>= (protocol-minor v) 14) (when (>= (protocol-minor v) 14)
(write-int (if cpu-affinity 1 0) s) (write-int (if cpu-affinity 1 0) port)
(when cpu-affinity (when cpu-affinity
(write-int cpu-affinity s))) (write-int cpu-affinity port)))
(when (>= (protocol-minor v) 11) (when (>= (protocol-minor v) 11)
(write-int (if reserve-space? 1 0) s)) (write-int (if reserve-space? 1 0) port))
(let ((s (%make-nix-server s (let ((conn (%make-nix-server port
(protocol-major v) (protocol-major v)
(protocol-minor v) (protocol-minor v)
(make-hash-table 100) (make-hash-table 100)
(make-hash-table 100)))) (make-hash-table 100))))
(let loop ((done? (process-stderr s))) (let loop ((done? (process-stderr conn)))
(or done? (process-stderr s))) (or done? (process-stderr conn)))
s)))))))) conn))))))))
(define (close-connection server) (define (close-connection server)
"Close the connection to SERVER." "Close the connection to SERVER."

View File

@ -171,6 +171,24 @@ AC_DEFUN([GUIX_CHECK_UNBUFFERED_CBIP], [
fi]) 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 dnl GUIX_TEST_ROOT_DIRECTORY
AC_DEFUN([GUIX_TEST_ROOT_DIRECTORY], [ AC_DEFUN([GUIX_TEST_ROOT_DIRECTORY], [
AC_CACHE_CHECK([for unit test root directory], AC_CACHE_CHECK([for unit test root directory],

View File

@ -183,26 +183,26 @@ endif BUILD_DAEMON_OFFLOAD
nodist_libexec_SCRIPTS = \ nodist_libexec_SCRIPTS = \
%D%/scripts/guix-authenticate %D%/scripts/guix-authenticate
# The '.service' file for systemd. # The '.service' files for systemd.
systemdservicedir = $(libdir)/systemd/system 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 $(top_builddir)/config.status
$(AM_V_GEN)$(MKDIR_P) "`dirname $@`"; \ $(AM_V_GEN)$(MKDIR_P) "`dirname $@`"; \
$(SED) -e 's|@''bindir''@|$(bindir)|' < \ $(SED) -e 's|@''bindir''@|$(bindir)|' < \
"$(srcdir)/etc/guix-daemon.service.in" > "$@.tmp"; \ "$(srcdir)/$<" > "$@.tmp"; \
mv "$@.tmp" "$@" mv "$@.tmp" "$@"
# The '.conf' job for Upstart. # The '.conf' jobs for Upstart.
upstartjobdir = $(libdir)/upstart/system 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 $(top_builddir)/config.status
$(AM_V_GEN)$(MKDIR_P) "`dirname $@`"; \ $(AM_V_GEN)$(MKDIR_P) "`dirname $@`"; \
$(SED) -e 's|@''bindir''@|$(bindir)|' < \ $(SED) -e 's|@''bindir''@|$(bindir)|' < \
"$(srcdir)/etc/guix-daemon.conf.in" > "$@.tmp"; \ "$(srcdir)/$<" > "$@.tmp"; \
mv "$@.tmp" "$@" mv "$@.tmp" "$@"
EXTRA_DIST += \ EXTRA_DIST += \