diff options
58 files changed, 3516 insertions, 1241 deletions
diff --git a/.gitignore b/.gitignore index 329d489713..b64f5ef4b0 100644 --- a/.gitignore +++ b/.gitignore @@ -50,6 +50,8 @@ /emacs/guix-helper.scm /etc/guix-daemon.conf /etc/guix-daemon.service +/etc/guix-publish.conf +/etc/guix-publish.service /guix-daemon /guix-register /guix/config.scm @@ -30,10 +30,11 @@ Ludovic Courtès <ludo@gnu.org> <ludovic.courtes@inria.fr> Mathieu Lirzin <mthl@gnu.org> <mthl@openmailbox.org> Mathieu Lirzin <mthl@gnu.org> <mathieu.lirzin@openmailbox.org> Nikita Karetnikov <nikita@karetnikov.org> <nikita.karetnikov@gmail.com> -ng0 <ng0@we.make.ritual.n0.is> <ngillmann@runbox.com> -ng0 <ng0@we.make.ritual.n0.is> <niasterisk@grrlz.net> -ng0 <ng0@we.make.ritual.n0.is> <ng@niasterisk.space> -ng0 <ng0@we.make.ritual.n0.is> <ng0@libertad.pw> +ng0 <ng0@libertad.pw> <ng0@we.make.ritual.n0.is> +ng0 <ng0@libertad.pw> <ngillmann@runbox.com> +ng0 <ng0@libertad.pw> <niasterisk@grrlz.net> +ng0 <ng0@libertad.pw> <ng@niasterisk.space> +ng0 <ng0@libertad.pw> Pjotr Prins <pjotr.public01@thebird.nl> Pjotr Prins <pjotr.public01@thebird.nl> <pjotr.public12@thebird.nl> Raimon Grau <raimonster@gmail.com> <raimon@3scale.net> diff --git a/build-aux/build-self.scm b/build-aux/build-self.scm index 59028305e7..485f91b4c0 100644 --- a/build-aux/build-self.scm +++ b/build-aux/build-self.scm @@ -61,6 +61,8 @@ (define guile-json (first (find-best-packages-by-name "guile-json" #f))) +(define guile-ssh + (first (find-best-packages-by-name "guile-ssh" #f))) ;; The actual build procedure. @@ -103,8 +105,14 @@ files." (use-modules (guix build pull)) (let ((json (string-append #$guile-json "/share/guile/site/2.0"))) - (set! %load-path (cons json %load-path)) - (set! %load-compiled-path (cons json %load-compiled-path))) + (set! %load-path + (cons* json + (string-append #$guile-ssh "/share/guile/site/2.0") + %load-path)) + (set! %load-compiled-path + (cons* json + (string-append #$guile-ssh "/lib/guile/2.0/site-ccache") + %load-compiled-path))) (build-guix #$output #$source diff --git a/config-daemon.ac b/config-daemon.ac index 8a3e6d8b60..056c939e39 100644 --- a/config-daemon.ac +++ b/config-daemon.ac @@ -128,12 +128,20 @@ if test "x$guix_build_daemon" = "xyes"; then dnl 'restore-file-set', which requires unbuffered custom binary input dnl ports from Guile >= 2.0.10.) GUIX_CHECK_UNBUFFERED_CBIP - guix_build_daemon_offload="$ac_cv_guix_cbips_support_setvbuf" - if test "x$guix_build_daemon_offload" = "xyes"; then - AC_DEFINE([HAVE_DAEMON_OFFLOAD_HOOK], [1], - [Define if the daemon's 'offload' build hook is being built.]) - fi + dnl Check for Guile-SSH, which is required by 'guix offload'. + GUIX_CHECK_GUILE_SSH + + case "x$ac_cv_guix_cbips_support_setvbuf$guix_cv_have_recent_guile_ssh" in + xyesyes) + guix_build_daemon_offload="yes" + AC_DEFINE([HAVE_DAEMON_OFFLOAD_HOOK], [1], + [Define if the daemon's 'offload' build hook is being built (requires Guile-SSH).]) + ;; + *) + guix_build_daemon_offload="no" + ;; + esac dnl Temporary directory used to store the daemon's data. GUIX_TEST_ROOT_DIRECTORY diff --git a/doc/guix.texi b/doc/guix.texi index 7381c2c6ba..5747484b20 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -453,7 +453,7 @@ If your host distro uses the systemd init system, this can be achieved with these commands: @example -# cp ~root/.guix-profile/lib/systemd/system/guix-daemon.service \ +# ln -s ~root/.guix-profile/lib/systemd/system/guix-daemon.service \ /etc/systemd/system/ # systemctl start guix-daemon && systemctl enable guix-daemon @end example @@ -461,7 +461,7 @@ with these commands: If your host distro uses the Upstart init system: @example -# cp ~root/.guix-profile/lib/upstart/system/guix-daemon.conf /etc/init/ +# ln -s ~root/.guix-profile/lib/upstart/system/guix-daemon.conf /etc/init/ # start guix-daemon @end example @@ -567,6 +567,12 @@ guix import}). It is of interest primarily for developers and not for casual users. @item +@c Note: We need at least 0.10.2 for 'channel-send-eof'. +Support for build offloading (@pxref{Daemon Offload Setup}) depends on +@uref{https://github.com/artyom-poptsov/guile-ssh, Guile-SSH}, +version 0.10.2 or later. + +@item When @url{http://zlib.net, zlib} is available, @command{guix publish} can compress build byproducts (@pxref{Invoking guix publish}). @end itemize @@ -814,9 +820,11 @@ available on the system---making it much harder to view them as @cindex offloading @cindex build hook -When desired, the build daemon can @dfn{offload} -derivation builds to other machines -running Guix, using the @code{offload} @dfn{build hook}. When that +When desired, the build daemon can @dfn{offload} derivation builds to +other machines running Guix, using the @code{offload} @dfn{build +hook}@footnote{This feature is available only when +@uref{https://github.com/artyom-poptsov/guile-ssh, Guile-SSH} is +present.}. When that feature is enabled, a list of user-specified build machines is read from @file{/etc/guix/machines.scm}; every time a build is requested, for instance via @code{guix build}, the daemon attempts to offload it to one @@ -832,16 +840,18 @@ The @file{/etc/guix/machines.scm} file typically looks like this: (list (build-machine (name "eightysix.example.org") (system "x86_64-linux") + (host-key "ssh-ed25519 AAAAC3Nza@dots{}") (user "bob") - (speed 2.)) ; incredibly fast! + (speed 2.)) ;incredibly fast! (build-machine (name "meeps.example.org") (system "mips64el-linux") + (host-key "ssh-rsa AAAAB3Nza@dots{}") (user "alice") (private-key (string-append (getenv "HOME") - "/.lsh/identity-for-guix")))) + "/.ssh/identity-for-guix")))) @end example @noindent @@ -875,31 +885,54 @@ The user account to use when connecting to the remote machine over SSH. Note that the SSH key pair must @emph{not} be passphrase-protected, to allow non-interactive logins. +@item host-key +This must be the machine's SSH @dfn{public host key} in OpenSSH format. +This is used to authenticate the machine when we connect to it. It is a +long string that looks like this: + +@example +ssh-ed25519 AAAAC3NzaC@dots{}mde+UhL hint@@example.org +@end example + +If the machine is running the OpenSSH daemon, @command{sshd}, the host +key can be found in a file such as +@file{/etc/ssh/ssh_host_ed25519_key.pub}. + +If the machine is running the SSH daemon of GNU@tie{}lsh, +@command{lshd}, the host key is in @file{/etc/lsh/host-key.pub} or a +similar file. It can be converted to the OpenSSH format using +@command{lsh-export-key} (@pxref{Converting keys,,, lsh, LSH Manual}): + +@example +$ lsh-export-key --openssh < /etc/lsh/host-key.pub +ssh-rsa AAAAB3NzaC1yc2EAAAAEOp8FoQAAAQEAs1eB46LV@dots{} +@end example + @end table A number of optional fields may be specified: -@table @code +@table @asis -@item port -Port number of SSH server on the machine (default: 22). +@item @code{port} (default: @code{22}) +Port number of SSH server on the machine. -@item private-key -The SSH private key file to use when connecting to the machine. +@item @code{private-key} (default: @file{~/.ssh/id_rsa}) +The SSH private key file to use when connecting to the machine, in +OpenSSH format. -Currently offloading uses GNU@tie{}lsh as its SSH client -(@pxref{Invoking lsh,,, GNU lsh Manual}). Thus, the key file here must -be an lsh key file. This may change in the future, though. +@item @code{daemon-socket} (default: @code{"/var/guix/daemon-socket/socket"}) +File name of the Unix-domain socket @command{guix-daemon} is listening +to on that machine. -@item parallel-builds -The number of builds that may run in parallel on the machine (1 by -default.) +@item @code{parallel-builds} (default: @code{1}) +The number of builds that may run in parallel on the machine. -@item speed +@item @code{speed} (default: @code{1.0}) A ``relative speed factor''. The offload scheduler will tend to prefer machines with a higher speed factor. -@item features +@item @code{features} (default: @code{'()}) A list of strings denoting specific features supported by the machine. An example is @code{"kvm"} for machines that have the KVM Linux modules and corresponding hardware support. Derivations can request features by @@ -915,7 +948,7 @@ machines, since offloading works by invoking the @code{guix archive} and this is the case by running: @example -lsh build-machine guile -c "'(use-modules (guix config))'" +ssh build-machine guile -c "'(use-modules (guix config))'" @end example There is one last thing to do once @file{machines.scm} is in place. As @@ -6055,6 +6088,30 @@ add a call to @code{guix-publish-service} in the @code{services} field of the @code{operating-system} declaration (@pxref{guix-publish-service, @code{guix-publish-service}}). +If you are instead running Guix on a ``foreign distro'', follow these +instructions:” + +@itemize +@item +If your host distro uses the systemd init system: + +@example +# ln -s ~root/.guix-profile/lib/systemd/system/guix-publish.service \ + /etc/systemd/system/ +# systemctl start guix-publish && systemctl enable guix-publish +@end example + +@item +If your host distro uses the Upstart init system: + +@example +# ln -s ~root/.guix-profile/lib/upstart/system/guix-publish.conf /etc/init/ +# start guix-publish +@end example + +@item +Otherwise, proceed similarly with your distro's init system. +@end itemize @node Invoking guix challenge @section Invoking @command{guix challenge} @@ -6641,27 +6698,26 @@ partition lives at @file{/dev/sda1}, a file system with the label mkfs.ext4 -L my-root /dev/sda1 @end example -@c FIXME: Uncomment this once GRUB fully supports encrypted roots. -@c A typical command sequence may be: -@c -@c @example -@c # fdisk /dev/sdX -@c @dots{} Create partitions etc.@dots{} -@c # cryptsetup luksFormat /dev/sdX1 -@c # cryptsetup open --type luks /dev/sdX1 my-partition -@c # mkfs.ext4 -L my-root /dev/mapper/my-partition -@c @end example +@cindex encrypted disk +If you are instead planning to encrypt the root partition, you can use +the Cryptsetup/LUKS utilities to do that (see @inlinefmtifelse{html, +@uref{https://linux.die.net/man/8/cryptsetup, @code{man cryptsetup}}, +@code{man cryptsetup}} for more information.) Assuming you want to +store the root partition on @file{/dev/sda1}, the command sequence would +be along these lines: -In addition to e2fsprogs, the suite of tools to manipulate -ext2/ext3/ext4 file systems, the installation image includes -Cryptsetup/LUKS for disk encryption. +@example +cryptsetup luksFormat /dev/sda1 +cryptsetup open --type luks /dev/sda1 my-partition +mkfs.ext4 -L my-root /dev/mapper/my-partition +@end example Once that is done, mount the target root partition under @file{/mnt} -with a command like (again, assuming @file{/dev/sda1} is the root -partition): +with a command like (again, assuming @code{my-root} is the label of the +root partition): @example -mount /dev/sda1 /mnt +mount LABEL=my-root /mnt @end example Finally, if you plan to use one or more swap partitions (@pxref{Memory @@ -6724,6 +6780,10 @@ Be sure that your partition labels match the value of their respective @code{device} fields in your @code{file-system} configuration, assuming your @code{file-system} configuration sets the value of @code{title} to @code{'label}. + +@item +If there are encrypted or RAID partitions, make sure to add a +@code{mapped-devices} field to describe them (@pxref{Mapped Devices}). @end itemize Once you are done preparing the configuration file, the new system must @@ -6968,7 +7028,9 @@ desired configuration. In particular, notice how we use @code{inherit} to create a new configuration which has the same values as the old configuration, but with a few modifications. -The configuration for a typical ``desktop'' usage, with the X11 display +@cindex encrypted disk +The configuration for a typical ``desktop'' usage, with an encrypted +root partition, the X11 display server, GNOME and Xfce (users can choose which of these desktop environments to use at the log-in screen by pressing @kbd{F1}), network management, power management, and more, would look like this: @@ -7293,13 +7355,16 @@ errors before being mounted. When true, the mount point is created if it does not exist yet. @item @code{dependencies} (default: @code{'()}) -This is a list of @code{<file-system>} objects representing file systems -that must be mounted before (and unmounted after) this one. +This is a list of @code{<file-system>} or @code{<mapped-device>} objects +representing file systems that must be mounted or mapped devices that +must be opened before (and unmounted or closed after) this one. As an example, consider a hierarchy of mounts: @file{/sys/fs/cgroup} is a dependency of @file{/sys/fs/cgroup/cpu} and @file{/sys/fs/cgroup/memory}. +Another example is a file system that depends on a mapped device, for +example for an encrypted partition (@pxref{Mapped Devices}). @end table @end deftp @@ -8407,13 +8472,22 @@ configure networking." @end deffn @cindex WPA Supplicant -@deffn {Scheme Procedure} wpa-supplicant-service @ - [#:wpa-supplicant @var{wpa-supplicant}] -Return a service that runs @url{https://w1.fi/wpa_supplicant/,WPA +@defvr {Scheme Variable} wpa-supplicant-service-type +This is the service type to run @url{https://w1.fi/wpa_supplicant/,WPA supplicant}, an authentication daemon required to authenticate against -encrypted WiFi or ethernet networks. Service is started to listen for +encrypted WiFi or ethernet networks. It is configured to listen for requests on D-Bus. -@end deffn + +The value of this service is the @code{wpa-supplicant} package to use. +Thus, it can be instantiated like this: + +@lisp +(use-modules (gnu services networking) + (gnu packages admin)) + +(service wpa-supplicant-type wpa-supplicant) +@end lisp +@end defvr @cindex NTP @cindex real time clock @@ -9979,7 +10053,7 @@ Return a service that runs @command{mysqld}, the MySQL or MariaDB database server. The optional @var{config} argument specifies the configuration for -@command{mysqld}, which should be a @code{<mysql-configuraiton>} object. +@command{mysqld}, which should be a @code{<mysql-configuration>} object. @end deffn @deftp {Data Type} mysql-configuration @@ -10001,16 +10075,11 @@ For MariaDB, the root password is empty. @cindex mail @cindex email The @code{(gnu services mail)} module provides Guix service definitions -for mail services. Currently the only implemented service is Dovecot, -an IMAP, POP3, and LMTP server. +for email services: IMAP, POP3, and LMTP servers, as well as mail +transport agents (MTAs). Lots of acronyms! These services are detailed +in the subsections below. -Guix does not yet have a mail transfer agent (MTA), although for some -lightweight purposes the @code{esmtp} relay-only MTA may suffice. Help -is needed to properly integrate a full MTA, such as Postfix. Patches -welcome! - -To add an IMAP/POP3 server to a GuixSD system, add a -@code{dovecot-service} to the operating system definition: +@subsubheading Dovecot Service @deffn {Scheme Procedure} dovecot-service [#:config (dovecot-configuration)] Return a service that runs the Dovecot IMAP/POP3/LMTP mail server. @@ -11366,18 +11435,47 @@ could instantiate a dovecot service like this: (string ""))) @end example +@subsubheading OpenSMTPD Service + +@deffn {Scheme Variable} opensmtpd-service-type +This is the type of the @uref{https://www.opensmtpd.org, OpenSMTPD} +service, whose value should be an @code{opensmtpd-configuration} object +as in this example: + +@example +(service opensmtpd-service-type + (opensmtpd-configuration + (config-file (local-file "./my-smtpd.conf")))) +@end example +@end deffn + +@deftp {Data Type} opensmtpd-configuration +Data type regresenting the configuration of opensmtpd. + +@table @asis +@item @code{package} (default: @var{opensmtpd}) +Package object of the OpenSMTPD SMTP server. + +@item @code{config-file} (default: @var{%default-opensmtpd-file}) +File-like object of the OpenSMTPD configuration file to use. By default +it listens on the loopback network interface, and allows for mail from +users and daemons on the local machine, as well as permitting email to +remote servers. Run @command{man smtpd.conf} for more information. + +@end table +@end deftp @node Kerberos Services @subsubsection Kerberos Services @cindex Kerberos -The @code{(gnu services Kerberos)} module provides services relating to +The @code{(gnu services kerberos)} module provides services relating to the authentication protocol @dfn{Kerberos}. @subsubheading PAM krb5 Service @cindex pam-krb5 -The pam-krb5 service allows for login authentication and password +The @code{pam-krb5} service allows for login authentication and password management via Kerberos. You will need this service if you want PAM enabled applications to authenticate users using Kerberos. diff --git a/etc/guix-publish.conf.in b/etc/guix-publish.conf.in new file mode 100644 index 0000000000..498fa295be --- /dev/null +++ b/etc/guix-publish.conf.in @@ -0,0 +1,12 @@ +# This is a "job" for the Upstart init system to launch 'guix-daemon'. +# Drop it in /etc/init to have 'guix-daemon' automatically started. + +description "Publish the GNU Guix store" + +start on runlevel [2345] + +stop on runlevel [016] + +task + +exec @bindir@/guix publish --user=nobody --port=8181 diff --git a/etc/guix-publish.service.in b/etc/guix-publish.service.in new file mode 100644 index 0000000000..fc4e3c21f3 --- /dev/null +++ b/etc/guix-publish.service.in @@ -0,0 +1,19 @@ +# This is a "service unit file" for the systemd init system to launch +# 'guix publish'. Drop it in /etc/systemd/system or similar to have +# 'guix publish' automatically started. + +[Unit] +Description=Publish the GNU Guix store + +[Service] +ExecStart=@bindir@/guix publish --user=nobody --port=8181 +Environment=GUIX_LOCPATH=/root/.guix-profile/lib/locale +RemainAfterExit=yes +StandardOutput=syslog +StandardError=syslog + +# See <https://lists.gnu.org/archive/html/guix-devel/2016-04/msg00608.html>. +TasksMax=1024 + +[Install] +WantedBy=multi-user.target diff --git a/gnu/build/install.scm b/gnu/build/install.scm index 3d1594e203..5c2b35632d 100644 --- a/gnu/build/install.scm +++ b/gnu/build/install.scm @@ -46,6 +46,11 @@ Note that the caller must make sure that GRUB.CFG is registered as a GC root so that the fonts, background images, etc. referred to by GRUB.CFG are not GC'd." (install-grub-config grub.cfg mount-point) + + ;; Tell 'grub-install' that there might be a LUKS-encrypted /boot or root + ;; partition. + (setenv "GRUB_ENABLE_CRYPTODISK" "y") + (unless (zero? (system* "grub-install" "--no-floppy" "--boot-directory" (string-append mount-point "/boot") diff --git a/gnu/build/marionette.scm b/gnu/build/marionette.scm index d36e1c8d09..506d6da420 100644 --- a/gnu/build/marionette.scm +++ b/gnu/build/marionette.scm @@ -21,10 +21,13 @@ #:use-module (srfi srfi-26) #:use-module (rnrs io ports) #:use-module (ice-9 match) + #:use-module (ice-9 popen) #:export (marionette? make-marionette marionette-eval marionette-control + marionette-screen-text + wait-for-screen-text %qwerty-us-keystrokes marionette-type)) @@ -45,7 +48,10 @@ (command marionette-command) ;list of strings (pid marionette-pid) ;integer (monitor marionette-monitor) ;port - (repl marionette-repl)) ;port + (repl %marionette-repl)) ;promise of a port + +(define-syntax-rule (marionette-repl marionette) + (force (%marionette-repl marionette))) (define* (wait-for-monitor-prompt port #:key (quiet? #t)) "Read from PORT until we have seen all of QEMU's monitor prompt. When @@ -131,21 +137,29 @@ QEMU monitor and to the guest's backdoor REPL." (close-port monitor) (wait-for-monitor-prompt monitor-conn) (display "read QEMU monitor prompt\n") - (match (accept* repl) - ((repl-conn . addr) - (display "connected to guest REPL\n") - (close-port repl) - (match (read repl-conn) - ('ready - (alarm 0) - (display "marionette is ready\n") - (marionette (append command extra-options) pid - monitor-conn repl-conn))))))))))) + + (marionette (append command extra-options) pid + monitor-conn + + ;; The following 'accept' call connects immediately, but + ;; we don't know whether the guest has connected until + ;; we actually receive the 'ready' message. + (match (accept* repl) + ((repl-conn . addr) + (display "connected to guest REPL\n") + (close-port repl) + ;; Delay reception of the 'ready' message so that the + ;; caller can already send monitor commands. + (delay + (match (read repl-conn) + ('ready + (display "marionette is ready\n") + repl-conn)))))))))))) (define (marionette-eval exp marionette) "Evaluate EXP in MARIONETTE's backdoor REPL. Return the result." (match marionette - (($ <marionette> command pid monitor repl) + (($ <marionette> command pid monitor (= force repl)) (write exp repl) (newline repl) (read repl)))) @@ -160,6 +174,55 @@ pcsys_monitor\")." (newline monitor) (wait-for-monitor-prompt monitor)))) +(define* (marionette-screen-text marionette + #:key + (ocrad "ocrad")) + "Take a screenshot of MARIONETTE, perform optical character +recognition (OCR), and return the text read from the screen as a string. Do +this by invoking OCRAD (file name for GNU Ocrad's command)" + (define (random-file-name) + (string-append "/tmp/marionette-screenshot-" + (number->string (random (expt 2 32)) 16) + ".ppm")) + + (let ((image (random-file-name))) + (dynamic-wind + (const #t) + (lambda () + (marionette-control (string-append "screendump " image) + marionette) + + ;; Tell Ocrad to invert the image colors (make it black on white) and + ;; to scale the image up, which significantly improves the quality of + ;; the result. In spite of this, be aware that OCR confuses "y" and + ;; "V" and sometimes erroneously introduces white space. + (let* ((pipe (open-pipe* OPEN_READ ocrad + "-i" "-s" "10" image)) + (text (get-string-all pipe))) + (unless (zero? (close-pipe pipe)) + (error "'ocrad' failed" ocrad)) + text)) + (lambda () + (false-if-exception (delete-file image)))))) + +(define* (wait-for-screen-text marionette predicate + #:key (timeout 30) (ocrad "ocrad")) + "Wait for TIMEOUT seconds or until the screen text on MARIONETTE matches +PREDICATE, whichever comes first. Raise an error when TIMEOUT is exceeded." + (define start + (car (gettimeofday))) + + (define end + (+ start timeout)) + + (let loop () + (if (> (car (gettimeofday)) end) + (error "'wait-for-screen-text' timeout" predicate) + (or (predicate (marionette-screen-text marionette #:ocrad ocrad)) + (begin + (sleep 1) + (loop)))))) + (define %qwerty-us-keystrokes ;; Maps "special" characters to their keystrokes. '((#\newline . "ret") diff --git a/gnu/local.mk b/gnu/local.mk index 52e0742301..ea5100141b 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -305,7 +305,6 @@ GNU_SYSTEM_MODULES = \ %D%/packages/pumpio.scm \ %D%/packages/pretty-print.scm \ %D%/packages/protobuf.scm \ - %D%/packages/psyc.scm \ %D%/packages/pv.scm \ %D%/packages/python.scm \ %D%/packages/qemu.scm \ @@ -400,6 +399,7 @@ GNU_SYSTEM_MODULES = \ %D%/services/admin.scm \ %D%/services/avahi.scm \ %D%/services/base.scm \ + %D%/services/configuration.scm \ %D%/services/cups.scm \ %D%/services/databases.scm \ %D%/services/dbus.scm \ @@ -506,6 +506,7 @@ dist_patch_DATA = \ %D%/packages/patches/cssc-missing-include.patch \ %D%/packages/patches/clucene-contribs-lib.patch \ %D%/packages/patches/cursynth-wave-rand.patch \ + %D%/packages/patches/cyrus-sasl-CVE-2013-4122.patch \ %D%/packages/patches/dbus-helper-search-path.patch \ %D%/packages/patches/devil-CVE-2009-3994.patch \ %D%/packages/patches/devil-fix-libpng.patch \ @@ -585,6 +586,10 @@ dist_patch_DATA = \ %D%/packages/patches/grub-gets-undeclared.patch \ %D%/packages/patches/grub-freetype.patch \ %D%/packages/patches/gsl-test-i686.patch \ + %D%/packages/patches/gst-plugins-good-fix-crashes.patch \ + %D%/packages/patches/gst-plugins-good-fix-invalid-read.patch \ + %D%/packages/patches/gst-plugins-good-fix-signedness.patch \ + %D%/packages/patches/gst-plugins-good-flic-bounds-check.patch \ %D%/packages/patches/guile-1.8-cpp-4.5.patch \ %D%/packages/patches/guile-arm-fixes.patch \ %D%/packages/patches/guile-default-utf8.patch \ diff --git a/gnu/packages/aspell.scm b/gnu/packages/aspell.scm index b7024124bd..b3ca380533 100644 --- a/gnu/packages/aspell.scm +++ b/gnu/packages/aspell.scm @@ -1,7 +1,8 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com> -;;; Copyright ©2016 John Darrington <jmd@gnu.org> +;;; Copyright © 2016 John Darrington <jmd@gnu.org> +;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il> ;;; ;;; This file is part of GNU Guix. ;;; @@ -155,3 +156,10 @@ dictionaries, including personal ones.") #:sha256 (base32 "0ffb87yjsh211hllpc4b9khqqrblial4pzi1h9r3v465z1yhn3j4"))) + +(define-public aspell-dict-he + (aspell-dictionary "he" "Hebrew" + #:version "1.0-0" + #:sha256 + (base32 + "13bhbghx5b8g0119g3wxd4n8mlf707y41vlf59irxjj0kynankfn"))) diff --git a/gnu/packages/audio.scm b/gnu/packages/audio.scm index 492f716ca9..b535448af1 100644 --- a/gnu/packages/audio.scm +++ b/gnu/packages/audio.scm @@ -8,6 +8,7 @@ ;;; Copyright © 2016 Alex Griffin <a@ajgrf.com> ;;; Copyright © 2016 ng0 <ng0@we.make.ritual.n0.is> ;;; Copyright © 2016 Lukas Gradl <lgradl@openmailbox.org> +;;; Copyright © 2016 Tobias Geerinckx-Rice <me@tobias.gr> ;;; ;;; This file is part of GNU Guix. ;;; @@ -1177,19 +1178,24 @@ well suited to all musical instruments and vocals.") (version "1.3.2") (source (origin (method url-fetch) - (uri (string-append - "http://factorial.hu/system/files/ir.lv2-" - version ".tar.gz")) + ;; The original home-page is gone. Download the tarball from an + ;; archive mirror instead. + (uri (list (string-append + "https://web.archive.org/web/20150803095032/" + "http://factorial.hu/system/files/ir.lv2-" + version ".tar.gz") + (string-append + "https://mirrors.kernel.org/gentoo/distfiles/ir.lv2-" + version ".tar.gz"))) (sha256 (base32 "1jh2z01l9m4ar7yz0n911df07dygc7n4cl59p7qdjbh0nvkm747g")))) (build-system gnu-build-system) (arguments - `(#:tests? #f ;no "check" target + `(#:tests? #f ; no tests #:make-flags (list (string-append "PREFIX=" (assoc-ref %outputs "out"))) - #:phases - ;; no configure script - (alist-delete 'configure %standard-phases))) + #:phases (modify-phases %standard-phases + (delete 'configure)))) ; no configure script (inputs `(("libsndfile" ,libsndfile) ("libsamplerate" ,libsamplerate) @@ -1203,7 +1209,9 @@ well suited to all musical instruments and vocals.") (list (search-path-specification (variable "LV2_PATH") (files '("lib/lv2"))))) - (home-page "http://factorial.hu/plugins/lv2/ir") + ;; Link to an archived copy of the home-page since the original is gone. + (home-page (string-append "https://web.archive.org/web/20150803095032/" + "http://factorial.hu/plugins/lv2/ir")) (synopsis "LV2 convolution reverb") (description "IR is a low-latency, real-time, high performance signal convolver diff --git a/gnu/packages/bioinformatics.scm b/gnu/packages/bioinformatics.scm index 773b5909b6..8d2cb93c7c 100644 --- a/gnu/packages/bioinformatics.scm +++ b/gnu/packages/bioinformatics.scm @@ -3693,6 +3693,58 @@ for sequences to be aligned and then, simultaneously with the alignment, predicts the locations of structural units in the sequences.") (license license:gpl2+))) +(define-public proteinortho + (package + (name "proteinortho") + (version "5.15") + (source + (origin + (method url-fetch) + (uri + (string-append + "http://www.bioinf.uni-leipzig.de/Software/proteinortho/proteinortho_v" + version "_src.tar.gz")) + (sha256 + (base32 + "05wacnnbx56avpcwhzlcf6b7s77swcpv3qnwz5sh1z54i51gg2ki")))) + (build-system gnu-build-system) + (arguments + `(#:test-target "test" + #:phases + (modify-phases %standard-phases + (replace 'configure + ;; There is no configure script, so we modify the Makefile directly. + (lambda* (#:key outputs #:allow-other-keys) + (substitute* "Makefile" + (("INSTALLDIR=.*") + (string-append + "INSTALLDIR=" (assoc-ref outputs "out") "/bin\n"))) + #t)) + (add-before 'install 'make-install-directory + ;; The install directory is not created during 'make install'. + (lambda* (#:key outputs #:allow-other-keys) + (mkdir-p (string-append (assoc-ref outputs "out") "/bin")) + #t)) + (add-after 'install 'wrap-programs + (lambda* (#:key inputs outputs #:allow-other-keys) + (let* ((path (getenv "PATH")) + (out (assoc-ref outputs "out")) + (binary (string-append out "/bin/proteinortho5.pl"))) + (wrap-program binary `("PATH" ":" prefix (,path)))) + #t))))) + (inputs + `(("perl" ,perl) + ("python" ,python-2) + ("blast+" ,blast+))) + (home-page "http://www.bioinf.uni-leipzig.de/Software/proteinortho") + (synopsis "Detect orthologous genes across species") + (description + "Proteinortho is a tool to detect orthologous genes across different +species. For doing so, it compares similarities of given gene sequences and +clusters them to find significant groups. The algorithm was designed to handle +large-scale data and can be applied to hundreds of species at once.") + (license license:gpl2+))) + (define-public pyicoteo (package (name "pyicoteo") @@ -3765,7 +3817,7 @@ partial genes, and identifies translation initiation sites.") (define-public roary (package (name "roary") - (version "3.6.8") + (version "3.7.0") (source (origin (method url-fetch) @@ -3774,7 +3826,7 @@ partial genes, and identifies translation initiation sites.") version ".tar.gz")) (sha256 (base32 - "0g0pzcv8y7n2w8q7c9q0a7s2ghkwci6w8smg9mjw4agad5cd7yaw")))) + "0x2hpb3nfsc6x2nq1788w0fhqfzc7cn2dp4xwyva9m3k6xlz0m43")))) (build-system perl-build-system) (arguments `(#:phases diff --git a/gnu/packages/bittorrent.scm b/gnu/packages/bittorrent.scm index ad67e02270..eff1b5a1c4 100644 --- a/gnu/packages/bittorrent.scm +++ b/gnu/packages/bittorrent.scm @@ -49,7 +49,7 @@ (define-public transmission (package (name "transmission") - (version "2.84") + (version "2.92") (source (origin (method url-fetch) (uri (string-append @@ -57,7 +57,7 @@ version ".tar.xz")) (sha256 (base32 - "1sxr1magqb5s26yvr5yhs1f7bmir8gl09niafg64lhgfnhv1kz59")))) + "0pykmhi7pdmzq47glbj8i2im6iarp4wnj4l1pyvsrnba61f0939s")))) (build-system glib-or-gtk-build-system) (outputs '("out" ; library and command-line interface "gui")) ; graphical user interface @@ -84,6 +84,7 @@ `(("inotify-tools" ,inotify-tools) ("libevent" ,libevent) ("curl" ,curl) + ("cyrus-sasl" ,cyrus-sasl) ("openssl" ,openssl) ("file" ,file) ("zlib" ,zlib) diff --git a/gnu/packages/chez.scm b/gnu/packages/chez.scm index 5edce56505..6b2b70f19e 100644 --- a/gnu/packages/chez.scm +++ b/gnu/packages/chez.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 Federico Beffa <beffa@fbengineering.ch> +;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il> ;;; ;;; This file is part of GNU Guix. ;;; @@ -34,7 +35,8 @@ #:use-module (gnu packages compression) #:use-module (gnu packages image) #:use-module (gnu packages xorg) - #:use-module (ice-9 match)) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1)) (define nanopass (let ((version "1.9")) @@ -94,8 +96,7 @@ (list ,(match (or (%current-target-system) (%current-system)) ("x86_64-linux" '(list "--machine=ta6le")) ("i686-linux" '(list "--machine=ti3le")) - ;; FIXME: Some people succeeded in cross-compiling to - ;; ARM. https://github.com/cisco/ChezScheme/issues/13 + ;; Let autodetection have its attempt on other architectures. (_ '()))) #:phases @@ -191,7 +192,9 @@ (find-files lib "scheme.boot")) #t)))))) ;; According to the documentation MIPS is not supported. - (supported-systems (delete "mips64el-linux" %supported-systems)) + ;; Cross-compiling for the Raspberry Pi is supported, but not native ARM. + (supported-systems (fold delete %supported-systems + '("mips64el-linux" "armhf-linux"))) (home-page "http://www.scheme.com") (synopsis "R6RS Scheme compiler and run-time") (description diff --git a/gnu/packages/compression.scm b/gnu/packages/compression.scm index b6c8604a23..bdf87562e4 100644 --- a/gnu/packages/compression.scm +++ b/gnu/packages/compression.scm @@ -603,24 +603,24 @@ writing of compressed data created with the zlib and bzip2 libraries.") (define-public lz4 (package (name "lz4") - (version "131") + (version "1.7.4.2") (source (origin (method url-fetch) (uri (string-append "https://github.com/Cyan4973/lz4/archive/" - "r" version ".tar.gz")) + "v" version ".tar.gz")) (sha256 - (base32 "1vfg305zvj50hwscad24wan9jar6nqj14gdk2hqyr7bb9mhh0kcx")) + (base32 "0l39bymif15rmmfz7h6wvrr853rix4wj8wbqq8z8fm49xa7gx9fb")) (file-name (string-append name "-" version ".tar.gz")))) (build-system gnu-build-system) - (native-inputs `(("valgrind" ,valgrind))) + (native-inputs `(("valgrind" ,valgrind))) ; for tests (arguments `(#:test-target "test" #:parallel-tests? #f ; tests fail if run in parallel #:make-flags (list "CC=gcc" (string-append "PREFIX=" (assoc-ref %outputs "out"))) #:phases (modify-phases %standard-phases - (delete 'configure)))) + (delete 'configure)))) ; no configure script (home-page "https://github.com/Cyan4973/lz4") (synopsis "Compression algorithm focused on speed") (description "LZ4 is a lossless compression algorithm, providing diff --git a/gnu/packages/cups.scm b/gnu/packages/cups.scm index 802accf6c6..0a8a10ecb4 100644 --- a/gnu/packages/cups.scm +++ b/gnu/packages/cups.scm @@ -317,14 +317,14 @@ device-specific programs to convert and print many types of files.") (define-public hplip (package (name "hplip") - (version "3.16.10") + (version "3.16.11") (source (origin (method url-fetch) (uri (string-append "mirror://sourceforge/hplip/hplip/" version "/hplip-" version ".tar.gz")) (sha256 (base32 - "117f1p0splg51ljn4nn97c0mbl0jba440ahb3d8njq7p6h1lxd25")))) + "094vkyr0rjng72m13dgr824cdl7q20x23qjxzih4w7l9njn0rqpn")))) (build-system gnu-build-system) (home-page "http://hplipopensource.com/") (synopsis "HP Printer Drivers") diff --git a/gnu/packages/cyrus-sasl.scm b/gnu/packages/cyrus-sasl.scm index 99ff1e228e..89a4a49797 100644 --- a/gnu/packages/cyrus-sasl.scm +++ b/gnu/packages/cyrus-sasl.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr> +;;; Copyright © 2016 Leo Famulari <leo@famulari.name> ;;; ;;; This file is part of GNU Guix. ;;; @@ -30,6 +31,7 @@ (define-public cyrus-sasl (package (name "cyrus-sasl") + (replacement cyrus-sasl/fixed) (version "2.1.26") (source (origin (method url-fetch) @@ -64,3 +66,10 @@ server writers.") (license (license:non-copyleft "file://COPYING" "See COPYING in the distribution.")) (home-page "http://cyrusimap.web.cmu.edu"))) + +(define cyrus-sasl/fixed + (package + (inherit cyrus-sasl) + (source (origin + (inherit (package-source cyrus-sasl)) + (patches (search-patches "cyrus-sasl-CVE-2013-4122.patch")))))) diff --git a/gnu/packages/engineering.scm b/gnu/packages/engineering.scm index f720906534..831e63beda 100644 --- a/gnu/packages/engineering.scm +++ b/gnu/packages/engineering.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2016 David Thompson <davet@gnu.org> ;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016 Theodoros Foradis <theodoros.for@openmailbox.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -29,6 +30,7 @@ #:use-module (guix store) #:use-module (guix utils) #:use-module ((guix licenses) #:prefix license:) + #:use-module (guix build-system cmake) #:use-module (guix build-system gnu) #:use-module (guix build-system cmake) #:use-module (gnu packages) @@ -39,6 +41,7 @@ #:use-module (gnu packages boost) #:use-module (gnu packages check) #:use-module (gnu packages compression) + #:use-module (gnu packages curl) #:use-module (gnu packages flex) #:use-module (gnu packages fontutils) #:use-module (gnu packages gd) @@ -55,9 +58,14 @@ #:use-module (gnu packages maths) #:use-module (gnu packages perl) #:use-module (gnu packages pkg-config) + #:use-module (gnu packages python) #:use-module (gnu packages qt) + #:use-module (gnu packages swig) #:use-module (gnu packages tcl) + #:use-module (gnu packages tls) #:use-module (gnu packages tex) + #:use-module (gnu packages wxwidgets) + #:use-module (gnu packages xorg) #:use-module (srfi srfi-1)) (define-public librecad @@ -588,3 +596,149 @@ fundamental, primitive shapes are represented as code in the user-level language.") (license (list license:lgpl2.1+ ;library license:gpl2+))))) ;Guile bindings + +;; We use kicad from a git commit, because support for boost 1.61.0 has been +;; recently added. +(define-public kicad + (let ((commit "4ee344e150bfaf3a6f3f7bf935fb96ae07c423fa") + (revision "1")) + (package + (name "kicad") + (version (string-append "4.0-" revision "." + (string-take commit 7))) + (source + (origin + (method git-fetch) + (uri (git-reference + (url "https://git.launchpad.net/kicad") + (commit commit))) + (sha256 + (base32 "0kf6r92nps0658i9n3p9vp5dzbssmc22lvjv5flyvnlf83l63s4n")) + (file-name (string-append name "-" version "-checkout")))) + (build-system cmake-build-system) + (arguments + `(#:out-of-source? #t + #:tests? #f ; no tests + #:configure-flags + (list "-DKICAD_STABLE_VERSION=ON" + "-DKICAD_REPO_NAME=stable" + ,(string-append "-DKICAD_BUILD_VERSION=4.0-" + (string-take commit 7)) + "-DCMAKE_BUILD_TYPE=Release" + "-DKICAD_SKIP_BOOST=ON"; Use our system's boost library. + "-DKICAD_SCRIPTING=ON" + "-DKICAD_SCRIPTING_MODULES=ON" + "-DKICAD_SCRIPTING_WXPYTHON=ON" + ;; Has to be set explicitely, as we don't have the wxPython + ;; headers in the wxwidgets store item, but in wxPython. + (string-append "-DCMAKE_CXX_FLAGS=-I" + (assoc-ref %build-inputs "wxpython") + "/include/wx-3.0") + "-DCMAKE_BUILD_WITH_INSTALL_RPATH=TRUE" + ;; TODO: Enable this when CA certs are working with curl. + "-DBUILD_GITHUB_PLUGIN=OFF") + #:phases + (modify-phases %standard-phases + (add-after 'install 'wrap-program + ;; Ensure correct Python at runtime. + (lambda* (#:key inputs outputs #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (python (assoc-ref inputs "python")) + (file (string-append out "/bin/kicad")) + (path (string-append + out + "/lib/python2.7/site-packages:" + (getenv "PYTHONPATH")))) + (wrap-program file + `("PYTHONPATH" ":" prefix (,path)) + `("PATH" ":" prefix + (,(string-append python "/bin:"))))) + #t))))) + (native-inputs + `(("boost" ,boost) + ("gettext" ,gnu-gettext) + ("pkg-config" ,pkg-config) + ("swig" ,swig) + ("zlib" ,zlib))) + (inputs + `(("cairo" ,cairo) + ("curl" ,curl) + ("desktop-file-utils" ,desktop-file-utils) + ("glew" ,glew) + ("glm" ,glm) + ("hicolor-icon-theme" ,hicolor-icon-theme) + ("libsm" ,libsm) + ("mesa" ,mesa) + ("openssl" ,openssl) + ("python" ,python-2) + ("wxwidgets" ,wxwidgets-gtk2) + ("wxpython" ,python2-wxpython))) + (home-page "http://kicad-pcb.org/") + (synopsis "Electronics Design Automation Suite") + (description "Kicad is a program for the formation of printed circuit +boards and electrical circuits. The software has a number of programs that +perform specific functions, for example, pcbnew (Editing PCB), eeschema (editing +electrical diagrams), gerbview (viewing Gerber files) and others.") + (license license:gpl3+)))) + +(define-public kicad-library + (let ((version "4.0.4")) + (package + (name "kicad-library") + (version version) + (source (origin + (method url-fetch) + (uri (string-append + "http://downloads.kicad-pcb.org/libraries/kicad-library-" + version ".tar.gz")) + (sha256 + (base32 + "1wyda58y39lhxml0xv1ngvddi0nqihx9bnlza46ajzms38ajvh12")))) + (build-system cmake-build-system) + (arguments + `(#:out-of-source? #t + #:tests? #f ; no tests + #:phases + (modify-phases %standard-phases + (add-after 'install 'install-footprints ; from footprints tarball + (lambda* (#:key inputs outputs #:allow-other-keys) + (zero? (system* "tar" "xvf" + (assoc-ref inputs "kicad-footprints") + "-C" (string-append (assoc-ref outputs "out") + "/share/kicad/modules") + "--strip-components=1")))) + ;; We change the default global footprint file, which is generated if + ;; it doesn't exist in user's home directory, from the one using the + ;; github plugin, to the one using the KISYSMOD environment path. + (add-after 'install-footprints 'use-pretty-footprint-table + (lambda* (#:key outputs #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (template-dir (string-append out "/share/kicad/template")) + (fp-lib-table (string-append template-dir "/fp-lib-table"))) + (delete-file fp-lib-table) + (copy-file (string-append fp-lib-table ".for-pretty") + fp-lib-table)) + #t))))) + (native-search-paths + (list (search-path-specification + (variable "KISYSMOD") ; footprint path + (files '("share/kicad/modules"))) + (search-path-specification + (variable "KISYS3DMOD") ; 3D model path + (files '("share/kicad/modules/packages3d"))))) + ;; Kicad distributes footprints in a separate tarball + (native-inputs + `(("kicad-footprints" + ,(origin + (method url-fetch) + (uri (string-append + "http://downloads.kicad-pcb.org/libraries/kicad-footprints-" + version ".tar.gz")) + (sha256 + (base32 + "0ya4gg6clz3vp2wrb67xwg0bhwh5q8ag39jjmpcp4zjcqs1f48rb")))))) + (home-page "http://kicad-pcb.org/") + (synopsis "Libraries for kicad") + (description "This package provides Kicad component, footprint and 3D +render model libraries.") + (license license:lgpl2.0+)))) diff --git a/gnu/packages/gstreamer.scm b/gnu/packages/gstreamer.scm index 5fe84ec2fc..86ea690e8b 100644 --- a/gnu/packages/gstreamer.scm +++ b/gnu/packages/gstreamer.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2015, 2016 Sou Bunnbu <iyzsong@gmail.com> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2016 Leo Famulari <leo@famulari.name> ;;; ;;; This file is part of GNU Guix. ;;; @@ -207,6 +208,10 @@ for the GStreamer multimedia library.") (uri (string-append "https://gstreamer.freedesktop.org/src/" name "/" name "-" version ".tar.xz")) + (patches (search-patches "gst-plugins-good-flic-bounds-check.patch" + "gst-plugins-good-fix-signedness.patch" + "gst-plugins-good-fix-invalid-read.patch" + "gst-plugins-good-fix-crashes.patch")) (sha256 (base32 "1hkcap9l2603266gyi6jgvx7frbvfmb7xhfhjizbczy1wykjwr57")))) diff --git a/gnu/packages/imagemagick.scm b/gnu/packages/imagemagick.scm index 99d8b76299..4e70212133 100644 --- a/gnu/packages/imagemagick.scm +++ b/gnu/packages/imagemagick.scm @@ -43,14 +43,14 @@ (define-public imagemagick (package (name "imagemagick") - (version "6.9.6-5") + (version "6.9.6-6") (source (origin (method url-fetch) (uri (string-append "mirror://imagemagick/ImageMagick-" version ".tar.xz")) (sha256 (base32 - "037lg2m0y5b17lyi34jdlkq4h03ck67j5m6wr84nvwd3jfx240cd")))) + "02hd0xvpm99wrix2didg8xnra4fla04y9vaks2vnijry3l0gxlcw")))) (build-system gnu-build-system) (arguments `(#:configure-flags '("--with-frozenpaths" "--without-gcc-arch") diff --git a/gnu/packages/ldc.scm b/gnu/packages/ldc.scm index 560fa497fb..6ea7f664bd 100644 --- a/gnu/packages/ldc.scm +++ b/gnu/packages/ldc.scm @@ -29,6 +29,7 @@ #:use-module (gnu packages compression) #:use-module (gnu packages libedit) #:use-module (gnu packages llvm) + #:use-module (gnu packages python) #:use-module (gnu packages textutils) #:use-module (gnu packages zip)) @@ -76,7 +77,7 @@ and freshness without requiring additional information from the user.") (define-public ldc (package (name "ldc") - (version "0.16.1") + (version "0.17.2") (source (origin (method url-fetch) (uri (string-append @@ -85,10 +86,9 @@ and freshness without requiring additional information from the user.") (file-name (string-append name "-" version ".tar.gz")) (sha256 (base32 - "1jvilxx0rpqmkbja4m69fhd5g09697xq7vyqp2hz4hvxmmmv4j40")))) + "0iksl6cvhsiwnlh15b7s9v8f3grxk27jn0vja9n4sad7fvfwmmlc")))) (build-system cmake-build-system) - ;; LDC currently only supports the x86_64 and i686 architectures. - (supported-systems '("x86_64-linux" "i686-linux")) + (supported-systems '("x86_64-linux" "i686-linux" "armhf-linux")) (arguments `(#:phases (modify-phases %standard-phases @@ -127,8 +127,10 @@ and freshness without requiring additional information from the user.") ("tzdata" ,tzdata) ("zlib" ,zlib))) (native-inputs - `(("llvm" ,llvm-3.7) - ("clang" ,clang-3.7) + `(("llvm" ,llvm) + ("clang" ,clang) + ("python-lit" ,python-lit) + ("python-wrapper" ,python-wrapper) ("unzip" ,unzip) ("phobos-src" ,(origin @@ -138,7 +140,7 @@ and freshness without requiring additional information from the user.") version ".tar.gz")) (sha256 (base32 - "0sgdj0536c4nb118yiw1f8lqy5d3g3lpg9l99l165lk9xy45l9z4")) + "07hh3ic3r755mq9hn9gfr0wlc5y8cr91xz2ydb6gqy4zy8jgp5s9")) (patches (search-patches "ldc-disable-tests.patch")))) ("druntime-src" ,(origin @@ -148,7 +150,7 @@ and freshness without requiring additional information from the user.") version ".tar.gz")) (sha256 (base32 - "0z4mkyddx6c4sy1vqgqvavz55083dsxws681qkh93jh1rpby9yg6")))) + "1m1dhday9dl3s04njmd29z7ism2xn2ksb9qlrwzykdgz27b3dk6x")))) ("dmd-testsuite-src" ,(origin (method url-fetch) @@ -157,7 +159,7 @@ and freshness without requiring additional information from the user.") version ".tar.gz")) (sha256 (base32 - "0yc6miidzgl9k33ygk7xcppmfd6kivqj02cvv4fmkbs3qz4yy3z1")))))) + "0n7gvalxwfmia4gag53r9qhcnk2cqrw3n4icj1yri0zkgc27pm60")))))) (home-page "http://wiki.dlang.org/LDC") (synopsis "LLVM compiler for the D programming language") (description diff --git a/gnu/packages/linux.scm b/gnu/packages/linux.scm index 308be10dbd..c504a1260b 100644 --- a/gnu/packages/linux.scm +++ b/gnu/packages/linux.scm @@ -2664,7 +2664,7 @@ and copy/paste text in the console and in xterm.") (define-public btrfs-progs (package (name "btrfs-progs") - (version "4.8.3") + (version "4.8.4") (source (origin (method url-fetch) (uri (string-append "mirror://kernel.org/linux/kernel/" @@ -2672,7 +2672,7 @@ and copy/paste text in the console and in xterm.") "btrfs-progs-v" version ".tar.xz")) (sha256 (base32 - "1wlflrygnpndppil9g12pk184f75g9qx1lkr0x1gijigglqhr9n1")))) + "1ib1ybpjhcymcycjiraz1vk01qlyvpwcg7mwfhmacdy3cvbfl9mz")))) (build-system gnu-build-system) (outputs '("out" "static")) ; static versions of binaries in "out" (~16MiB!) diff --git a/gnu/packages/maths.scm b/gnu/packages/maths.scm index 0c51f6d54f..e432ed5c05 100644 --- a/gnu/packages/maths.scm +++ b/gnu/packages/maths.scm @@ -563,7 +563,10 @@ incompatible with HDF5.") (inputs `(("zlib" ,zlib))) (arguments - `(#:phases + `(;; Some of the users, notably Flann, need the C++ interface. + #:configure-flags '("--enable-cxx") + + #:phases (modify-phases %standard-phases (add-before 'configure 'patch-configure (lambda _ diff --git a/gnu/packages/messaging.scm b/gnu/packages/messaging.scm index 72b89067f0..8660915bb0 100644 --- a/gnu/packages/messaging.scm +++ b/gnu/packages/messaging.scm @@ -5,7 +5,7 @@ ;;; Copyright © 2015 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2015, 2016 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2015 Efraim Flashner <efraim@flashner.co.il> -;;; Copyright © 2016 ng0 <ngillmann@runbox.com> +;;; Copyright © 2016 ng0 <ng0@libertad.pw> ;;; Copyright © 2016 Andy Patterson <ajpatter@uwaterloo.ca> ;;; Copyright © 2016 Clément Lassieur <clement@lassieur.org> ;;; @@ -33,6 +33,7 @@ #:use-module (guix build-system gnu) #:use-module (guix build-system glib-or-gtk) #:use-module (guix build-system python) + #:use-module (guix build-system perl) #:use-module (gnu packages) #:use-module (gnu packages aidc) #:use-module (gnu packages autotools) @@ -43,11 +44,13 @@ #:use-module (gnu packages databases) #:use-module (gnu packages documentation) #:use-module (gnu packages enchant) + #:use-module (gnu packages gettext) #:use-module (gnu packages gnome) #:use-module (gnu packages gtk) #:use-module (gnu packages xorg) #:use-module (gnu packages xdisorg) #:use-module (gnu packages libcanberra) + #:use-module (gnu packages man) #:use-module (gnu packages networking) #:use-module (gnu packages libidn) #:use-module (gnu packages lua) @@ -57,6 +60,7 @@ #:use-module (gnu packages pkg-config) #:use-module (gnu packages glib) #:use-module (gnu packages python) + #:use-module (gnu packages pcre) #:use-module (gnu packages perl) #:use-module (gnu packages tcl) #:use-module (gnu packages compression) @@ -67,8 +71,10 @@ #:use-module (gnu packages icu4c) #:use-module (gnu packages qt) #:use-module (gnu packages video) + #:use-module (gnu packages web) #:use-module (gnu packages xiph) #:use-module (gnu packages audio) + #:use-module (gnu packages bison) #:use-module (gnu packages fontutils)) (define-public libotr @@ -859,4 +865,192 @@ into existing applications.") (home-page "https://camaya.net/gloox") (license license:gpl3))) +(define-public perl-net-psyc + (package + (name "perl-net-psyc") + (version "1.1") + (source + (origin + (method url-fetch) + (uri (string-append "http://perlpsyc.psyc.eu/" + "perlpsyc-" version ".zip")) + (file-name (string-append name "-" version ".zip")) + (sha256 + (base32 + "1lw6807qrbmvzbrjn1rna1dhir2k70xpcjvyjn45y35hav333a42")) + ;; psycmp3 currently depends on MP3::List and rxaudio (shareware), + ;; we can add it back when this is no longer the case. + (snippet '(delete-file "contrib/psycmp3")))) + (build-system perl-build-system) + (inputs + `(("perl-curses" ,perl-curses) + ("perl-io-socket-ssl" ,perl-io-socket-ssl))) + (arguments + `(#:phases + (modify-phases %standard-phases + (delete 'configure) ; No configure script + ;; There is a Makefile, but it does not install everything + ;; (leaves out psycion) and says + ;; "# Just to give you a rough idea". XXX: Fix it upstream. + (replace 'build + (lambda _ + (zero? (system* "make" "manuals")))) + (replace 'install + (lambda* (#:key outputs #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (doc (string-append out "/share/doc/perl-net-psyc")) + (man1 (string-append out "/share/man/man1")) + (man3 (string-append out "/share/man/man3")) + (bin (string-append out "/bin")) + (libpsyc (string-append out "/lib/psyc/ion")) + (libperl (string-append out "/lib/perl5/site_perl/" + ,(package-version perl)))) + + (copy-recursively "lib/perl5" libperl) + (copy-recursively "lib/psycion" libpsyc) + (copy-recursively "bin" bin) + (install-file "cgi/psycpager" (string-append doc "/cgi")) + (copy-recursively "contrib" (string-append doc "/contrib")) + (copy-recursively "hooks" (string-append doc "/hooks")) + (copy-recursively "sdj" (string-append doc "/sdj")) + (install-file "README.txt" doc) + (install-file "TODO.txt" doc) + (copy-recursively "share/man/man1" man1) + (copy-recursively "share/man/man3" man3) + #t))) + (add-after 'install 'wrap-programs + (lambda* (#:key outputs #:allow-other-keys) + ;; Make sure all executables in "bin" find the Perl modules + ;; provided by this package at runtime. + (let* ((out (assoc-ref outputs "out")) + (bin (string-append out "/bin/")) + (path (getenv "PERL5LIB"))) + (for-each (lambda (file) + (wrap-program file + `("PERL5LIB" ":" prefix (,path)))) + (find-files bin "\\.*$")) + #t)))))) + (description + "@code{Net::PSYC} with support for TCP, UDP, Event.pm, @code{IO::Select} and +Gtk2 event loops. This package includes 12 applications and additional scripts: +psycion (a @uref{http://about.psyc.eu,PSYC} chat client), remotor (a control console +for @uref{https://torproject.org,tor} router) and many more.") + (synopsis "Perl implementation of PSYC protocol") + (home-page "http://perlpsyc.psyc.eu/") + (license (list license:gpl2 + (package-license perl) + ;; contrib/irssi-psyc.pl: + license:public-domain + ;; bin/psycplay states AGPL with no version: + license:agpl3+)))) + +(define-public libpsyc + (package + (name "libpsyc") + (version "20160913") + (source (origin + (method url-fetch) + (uri (string-append "http://www.psyced.org/files/" + name "-" version ".tar.xz")) + (sha256 + (base32 + "14q89fxap05ajkfn20rnhc6b1h4i3i2adyr7y6hs5zqwb2lcmc1p")))) + (build-system gnu-build-system) + (native-inputs + `(("perl" ,perl) + ("netcat" ,netcat) + ("procps" ,procps))) + (arguments + `(#:make-flags + (list "CC=gcc" + (string-append "PREFIX=" (assoc-ref %outputs "out"))) + #:phases + (modify-phases %standard-phases + ;; The rust bindings are the only ones in use, the lpc bindings + ;; are in psyclpc. The other bindings are not used by anything, + ;; the chances are high that the bindings do not even work, + ;; therefore we do not include them. + ;; TODO: Get a cargo build system in Guix. + (delete 'configure)))) ; no configure script + (home-page "http://about.psyc.eu/libpsyc") + (description + "@code{libpsyc} is a PSYC library in C which implements +core aspects of PSYC, useful for all kinds of clients and servers +including psyced.") + (synopsis "PSYC library in C") + (license license:agpl3+))) + +;; This commit removes the historic bundled pcre and makes psyclpc reproducible. +(define-public psyclpc + (let* ((commit "61cf9aa81297085e5c40170fd01221c752f8deba") + (revision "2")) + (package + (name "psyclpc") + (version (string-append "20160821-" revision "." (string-take commit 7))) + (source (origin + (method git-fetch) + (uri (git-reference + (url "git://git.psyced.org/git/psyclpc") + (commit commit))) + (file-name (string-append name "-" version "-checkout")) + (sha256 + (base32 + "1viwqymbhn3cwvx0zl58rlzl5gw47zxn0ldg2nbi55ghm5zxl1z5")))) + (build-system gnu-build-system) + (arguments + `(#:tests? #f ; There are no tests/checks. + #:configure-flags + ;; If you have questions about this part, look at + ;; "src/settings/psyced" and the ebuild. + (list + "--enable-use-tls=yes" + "--enable-use-mccp" ; Mud Client Compression Protocol, leave this enabled. + (string-append "--prefix=" + (assoc-ref %outputs "out")) + ;; src/Makefile: Set MUD_LIB to the directory which contains + ;; the mud data. defaults to MUD_LIB = @libdir@ + (string-append "--libdir=" + (assoc-ref %outputs "out") + "/opt/psyced/world") + (string-append "--bindir=" + (assoc-ref %outputs "out") + "/opt/psyced/bin") + ;; src/Makefile: Set ERQ_DIR to directory which contains the + ;; stuff which ERQ can execute (hopefully) savely. Was formerly + ;; defined in config.h. defaults to ERQ_DIR= @libexecdir@ + (string-append "--libexecdir=" + (assoc-ref %outputs "out") + "/opt/psyced/run")) + #:phases + (modify-phases %standard-phases + (add-before 'configure 'chdir-to-src + ;; We need to pass this as env variables + ;; and manually change the directory. + (lambda _ + (chdir "src") + (setenv "CONFIG_SHELL" (which "sh")) + (setenv "SHELL" (which "sh")) + #t))) + #:make-flags (list "install-all"))) + (inputs + `(("zlib" ,zlib) + ("openssl" ,openssl) + ("pcre" ,pcre))) + (native-inputs + `(("pkg-config" ,pkg-config) + ("bison" ,bison) + ("gettext" ,gettext-minimal) + ("help2man" ,help2man) + ("autoconf" ,autoconf) + ("automake" ,automake))) + (home-page "http://lpc.psyc.eu/") + (synopsis "psycLPC is a multi-user network server programming language") + (description + "LPC is a bytecode language, invented to specifically implement +multi user virtual environments on the internet. This technology is used for +MUDs and also the psyced implementation of the Protocol for SYnchronous +Conferencing (PSYC). psycLPC is a fork of LDMud with some new features and +many bug fixes.") + (license license:gpl2)))) + ;;; messaging.scm ends here diff --git a/gnu/packages/music.scm b/gnu/packages/music.scm index 64e7455603..78ca558b2d 100644 --- a/gnu/packages/music.scm +++ b/gnu/packages/music.scm @@ -234,7 +234,7 @@ many input formats and provides a customisable Vi-style user interface.") (define-public hydrogen (package (name "hydrogen") - (version "0.9.6.1") + (version "0.9.7") (source (origin (method url-fetch) (uri (string-append @@ -242,7 +242,7 @@ many input formats and provides a customisable Vi-style user interface.") version ".tar.gz")) (sha256 (base32 - "0vxnaqfmcv7hhk0cj67imdcqngspnck7f0wfmvhfgfqa7x1xznll")))) + "1dy2jfkdw0nchars4xi4isrz66fqn53a9qk13bqza7lhmsg3s3qy")))) (build-system cmake-build-system) (arguments `(#:test-target "tests")) @@ -1638,14 +1638,14 @@ computer's keyboard.") (define-public qtractor (package (name "qtractor") - (version "0.7.9") + (version "0.8.0") (source (origin (method url-fetch) (uri (string-append "http://downloads.sourceforge.net/qtractor/" "qtractor-" version ".tar.gz")) (sha256 (base32 - "0pp459kfgrnngj373gnwwl43xjz32lmyf7v62p2nnjh6c7wr1ryq")))) + "17v563liyqcvil204ry1qfp09d91944nqz2ig33f5c3pyg4z2427")))) (build-system gnu-build-system) (arguments `(#:tests? #f)) ; no "check" target (inputs diff --git a/gnu/packages/patches/cyrus-sasl-CVE-2013-4122.patch b/gnu/packages/patches/cyrus-sasl-CVE-2013-4122.patch new file mode 100644 index 0000000000..fc72e42e03 --- /dev/null +++ b/gnu/packages/patches/cyrus-sasl-CVE-2013-4122.patch @@ -0,0 +1,130 @@ +Fix CVE-2013-4122. + +https://cve.mitre.org/cgi-bin/cvename.cgi?name=CVE-2013-4122 + +Patch copied from upstream source repository: +https://github.com/cyrusimap/cyrus-sasl/commit/dedad73e5e7a75d01a5f3d5a6702ab8ccd2ff40d + +From dedad73e5e7a75d01a5f3d5a6702ab8ccd2ff40d Mon Sep 17 00:00:00 2001 +From: mancha <mancha1@hush.com> +Date: Thu, 11 Jul 2013 10:08:07 +0100 +Subject: Handle NULL returns from glibc 2.17+ crypt() + +Starting with glibc 2.17 (eglibc 2.17), crypt() fails with EINVAL +(w/ NULL return) if the salt violates specifications. Additionally, +on FIPS-140 enabled Linux systems, DES/MD5-encrypted passwords +passed to crypt() fail with EPERM (w/ NULL return). + +When using glibc's crypt(), check return value to avoid a possible +NULL pointer dereference. + +Patch by mancha1@hush.com. +--- + pwcheck/pwcheck_getpwnam.c | 3 ++- + pwcheck/pwcheck_getspnam.c | 4 +++- + saslauthd/auth_getpwent.c | 4 +++- + saslauthd/auth_shadow.c | 8 +++----- + 4 files changed, 11 insertions(+), 8 deletions(-) + +diff --git a/pwcheck/pwcheck_getpwnam.c b/pwcheck/pwcheck_getpwnam.c +index 4b34222..400289c 100644 +--- a/pwcheck/pwcheck_getpwnam.c ++++ b/pwcheck/pwcheck_getpwnam.c +@@ -32,6 +32,7 @@ char *userid; + char *password; + { + char* r; ++ char* crpt_passwd; + struct passwd *pwd; + + pwd = getpwnam(userid); +@@ -41,7 +42,7 @@ char *password; + else if (pwd->pw_passwd[0] == '*') { + r = "Account disabled"; + } +- else if (strcmp(pwd->pw_passwd, crypt(password, pwd->pw_passwd)) != 0) { ++ else if (!(crpt_passwd = crypt(password, pwd->pw_passwd)) || strcmp(pwd->pw_passwd, (const char *)crpt_passwd) != 0) { + r = "Incorrect password"; + } + else { +diff --git a/pwcheck/pwcheck_getspnam.c b/pwcheck/pwcheck_getspnam.c +index 2b11286..6d607bb 100644 +--- a/pwcheck/pwcheck_getspnam.c ++++ b/pwcheck/pwcheck_getspnam.c +@@ -32,13 +32,15 @@ char *userid; + char *password; + { + struct spwd *pwd; ++ char *crpt_passwd; + + pwd = getspnam(userid); + if (!pwd) { + return "Userid not found"; + } + +- if (strcmp(pwd->sp_pwdp, crypt(password, pwd->sp_pwdp)) != 0) { ++ crpt_passwd = crypt(password, pwd->sp_pwdp); ++ if (!crpt_passwd || strcmp(pwd->sp_pwdp, (const char *)crpt_passwd) != 0) { + return "Incorrect password"; + } + else { +diff --git a/saslauthd/auth_getpwent.c b/saslauthd/auth_getpwent.c +index fc8029d..d4ebe54 100644 +--- a/saslauthd/auth_getpwent.c ++++ b/saslauthd/auth_getpwent.c +@@ -77,6 +77,7 @@ auth_getpwent ( + { + /* VARIABLES */ + struct passwd *pw; /* pointer to passwd file entry */ ++ char *crpt_passwd; /* encrypted password */ + int errnum; + /* END VARIABLES */ + +@@ -105,7 +106,8 @@ auth_getpwent ( + } + } + +- if (strcmp(pw->pw_passwd, (const char *)crypt(password, pw->pw_passwd))) { ++ crpt_passwd = crypt(password, pw->pw_passwd); ++ if (!crpt_passwd || strcmp(pw->pw_passwd, (const char *)crpt_passwd)) { + if (flags & VERBOSE) { + syslog(LOG_DEBUG, "DEBUG: auth_getpwent: %s: invalid password", login); + } +diff --git a/saslauthd/auth_shadow.c b/saslauthd/auth_shadow.c +index 677131b..1988afd 100644 +--- a/saslauthd/auth_shadow.c ++++ b/saslauthd/auth_shadow.c +@@ -210,8 +210,8 @@ auth_shadow ( + RETURN("NO Insufficient permission to access NIS authentication database (saslauthd)"); + } + +- cpw = strdup((const char *)crypt(password, sp->sp_pwdp)); +- if (strcmp(sp->sp_pwdp, cpw)) { ++ cpw = crypt(password, sp->sp_pwdp); ++ if (!cpw || strcmp(sp->sp_pwdp, (const char *)cpw)) { + if (flags & VERBOSE) { + /* + * This _should_ reveal the SHADOW_PW_LOCKED prefix to an +@@ -221,10 +221,8 @@ auth_shadow ( + syslog(LOG_DEBUG, "DEBUG: auth_shadow: pw mismatch: '%s' != '%s'", + sp->sp_pwdp, cpw); + } +- free(cpw); + RETURN("NO Incorrect password"); + } +- free(cpw); + + /* + * The following fields will be set to -1 if: +@@ -286,7 +284,7 @@ auth_shadow ( + RETURN("NO Invalid username"); + } + +- if (strcmp(upw->upw_passwd, crypt(password, upw->upw_passwd)) != 0) { ++ if (!(cpw = crypt(password, upw->upw_passwd)) || (strcmp(upw->upw_passwd, (const char *)cpw) != 0)) { + if (flags & VERBOSE) { + syslog(LOG_DEBUG, "auth_shadow: pw mismatch: %s != %s", + password, upw->upw_passwd); +-- +cgit v0.12 + diff --git a/gnu/packages/patches/gst-plugins-good-fix-crashes.patch b/gnu/packages/patches/gst-plugins-good-fix-crashes.patch new file mode 100644 index 0000000000..c36a595608 --- /dev/null +++ b/gnu/packages/patches/gst-plugins-good-fix-crashes.patch @@ -0,0 +1,1047 @@ +Fixes upstream bug #774859 (flic decoder: Invalid memory read in +flx_decode_chunks): + +https://bugzilla.gnome.org/show_bug.cgi?id=774859 + +Patch copied from upstream source repository: + +https://cgit.freedesktop.org/gstreamer/gst-plugins-good/commit/?id=be670f0daf67304fb92c76aa09c30cae0bfd1fe4 + +From be670f0daf67304fb92c76aa09c30cae0bfd1fe4 Mon Sep 17 00:00:00 2001 +From: Matthew Waters <matthew@centricular.com> +Date: Wed, 23 Nov 2016 07:09:06 +1100 +Subject: [PATCH] flxdec: rewrite logic based on GstByteReader/Writer + +Solves overreading/writing the given arrays and will error out if the +streams asks to do that. + +Also does more error checking that the stream is valid and won't +overrun any allocated arrays. Also mitigate integer overflow errors +calculating allocation sizes. + +https://bugzilla.gnome.org/show_bug.cgi?id=774859 +--- + gst/flx/flx_color.c | 1 - + gst/flx/flx_fmt.h | 72 ------- + gst/flx/gstflxdec.c | 610 ++++++++++++++++++++++++++++++++++++---------------- + gst/flx/gstflxdec.h | 4 +- + 4 files changed, 427 insertions(+), 260 deletions(-) + +diff --git a/gst/flx/flx_color.c b/gst/flx/flx_color.c +index 047bfdf..3a58135 100644 +--- a/gst/flx/flx_color.c ++++ b/gst/flx/flx_color.c +@@ -101,7 +101,6 @@ flx_set_palette_vector (FlxColorSpaceConverter * flxpal, guint start, guint num, + } else { + memcpy (&flxpal->palvec[start * 3], newpal, grab * 3); + } +- + } + + void +diff --git a/gst/flx/flx_fmt.h b/gst/flx/flx_fmt.h +index 9ab31ba..abff200 100644 +--- a/gst/flx/flx_fmt.h ++++ b/gst/flx/flx_fmt.h +@@ -123,78 +123,6 @@ typedef struct _FlxFrameType + } FlxFrameType; + #define FlxFrameTypeSize 10 + +-#if G_BYTE_ORDER == G_BIG_ENDIAN +-#define LE_TO_BE_16(i16) ((guint16) (((i16) << 8) | ((i16) >> 8))) +-#define LE_TO_BE_32(i32) \ +- (((guint32) (LE_TO_BE_16((guint16) (i32))) << 16) | (LE_TO_BE_16((i32) >> 16))) +- +-#define FLX_FRAME_TYPE_FIX_ENDIANNESS(frm_type_p) \ +- do { \ +- (frm_type_p)->chunks = LE_TO_BE_16((frm_type_p)->chunks); \ +- (frm_type_p)->delay = LE_TO_BE_16((frm_type_p)->delay); \ +- } while(0) +- +-#define FLX_HUFFMAN_TABLE_FIX_ENDIANNESS(hffmn_table_p) \ +- do { \ +- (hffmn_table_p)->codelength = \ +- LE_TO_BE_16((hffmn_table_p)->codelength); \ +- (hffmn_table_p)->numcodes = LE_TO_BE_16((hffmn_table_p)->numcodes); \ +- } while(0) +- +-#define FLX_SEGMENT_TABLE_FIX_ENDIANNESS(sgmnt_table_p) \ +- ((sgmnt_table_p)->segments = LE_TO_BE_16((sgmnt_table_p)->segments)) +- +-#define FLX_PREFIX_CHUNK_FIX_ENDIANNESS(prfx_chnk_p) \ +- do { \ +- (prfx_chnk_p)->chunks = LE_TO_BE_16((prfx_chnk_p)->chunks); \ +- } while(0) +- +-#define FLX_FRAME_CHUNK_FIX_ENDIANNESS(frm_chnk_p) \ +- do { \ +- (frm_chnk_p)->size = LE_TO_BE_32((frm_chnk_p)->size); \ +- (frm_chnk_p)->id = LE_TO_BE_16((frm_chnk_p)->id); \ +- } while(0) +- +-#define FLX_HDR_FIX_ENDIANNESS(hdr_p) \ +- do { \ +- (hdr_p)->size = LE_TO_BE_32((hdr_p)->size); \ +- (hdr_p)->type = LE_TO_BE_16((hdr_p)->type); \ +- (hdr_p)->frames = LE_TO_BE_16((hdr_p)->frames); \ +- (hdr_p)->width = LE_TO_BE_16((hdr_p)->width); \ +- (hdr_p)->height = LE_TO_BE_16((hdr_p)->height); \ +- (hdr_p)->depth = LE_TO_BE_16((hdr_p)->depth); \ +- (hdr_p)->flags = LE_TO_BE_16((hdr_p)->flags); \ +- (hdr_p)->speed = LE_TO_BE_32((hdr_p)->speed); \ +- (hdr_p)->reserved1 = LE_TO_BE_16((hdr_p)->reserved1); \ +- (hdr_p)->created = LE_TO_BE_32((hdr_p)->created); \ +- (hdr_p)->creator = LE_TO_BE_32((hdr_p)->creator); \ +- (hdr_p)->updated = LE_TO_BE_32((hdr_p)->updated); \ +- (hdr_p)->updater = LE_TO_BE_32((hdr_p)->updater); \ +- (hdr_p)->aspect_dx = LE_TO_BE_16((hdr_p)->aspect_dx); \ +- (hdr_p)->aspect_dy = LE_TO_BE_16((hdr_p)->aspect_dy); \ +- (hdr_p)->ext_flags = LE_TO_BE_16((hdr_p)->ext_flags); \ +- (hdr_p)->keyframes = LE_TO_BE_16((hdr_p)->keyframes); \ +- (hdr_p)->totalframes = LE_TO_BE_16((hdr_p)->totalframes); \ +- (hdr_p)->req_memory = LE_TO_BE_32((hdr_p)->req_memory); \ +- (hdr_p)->max_regions = LE_TO_BE_16((hdr_p)->max_regions); \ +- (hdr_p)->transp_num = LE_TO_BE_16((hdr_p)->transp_num); \ +- (hdr_p)->oframe1 = LE_TO_BE_32((hdr_p)->oframe1); \ +- (hdr_p)->oframe2 = LE_TO_BE_32((hdr_p)->oframe2); \ +- } while(0) +-#else +- +-#define LE_TO_BE_16(i16) ((i16)) +-#define LE_TO_BE_32(i32) ((i32)) +- +-#define FLX_FRAME_TYPE_FIX_ENDIANNESS(frm_type_p) +-#define FLX_HUFFMAN_TABLE_FIX_ENDIANNESS(hffmn_table_p) +-#define FLX_SEGMENT_TABLE_FIX_ENDIANNESS(sgmnt_table_p) +-#define FLX_PREFIX_CHUNK_FIX_ENDIANNESS(prfx_chnk_p) +-#define FLX_FRAME_CHUNK_FIX_ENDIANNESS(frm_chnk_p) +-#define FLX_HDR_FIX_ENDIANNESS(hdr_p) +- +-#endif /* G_BYTE_ORDER == G_BIG_ENDIAN */ +- + G_END_DECLS + + #endif /* __GST_FLX_FMT_H__ */ +diff --git a/gst/flx/gstflxdec.c b/gst/flx/gstflxdec.c +index a237976..aa1bed5 100644 +--- a/gst/flx/gstflxdec.c ++++ b/gst/flx/gstflxdec.c +@@ -1,5 +1,6 @@ + /* GStreamer + * Copyright (C) <1999> Erik Walthinsen <omega@temple-baptist.com> ++ * Copyright (C) <2016> Matthew Waters <matthew@centricular.com> + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library General Public +@@ -24,6 +25,7 @@ + /* + * http://www.coolutils.com/Formats/FLI + * http://woodshole.er.usgs.gov/operations/modeling/flc.html ++ * http://www.compuphase.com/flic.htm + */ + + #ifdef HAVE_CONFIG_H +@@ -73,10 +75,14 @@ static GstStateChangeReturn gst_flxdec_change_state (GstElement * element, + static gboolean gst_flxdec_src_query_handler (GstPad * pad, GstObject * parent, + GstQuery * query); + +-static void flx_decode_color (GstFlxDec *, guchar *, guchar *, gint); +-static gboolean flx_decode_brun (GstFlxDec *, guchar *, guchar *); +-static gboolean flx_decode_delta_fli (GstFlxDec *, guchar *, guchar *); +-static gboolean flx_decode_delta_flc (GstFlxDec *, guchar *, guchar *); ++static gboolean flx_decode_color (GstFlxDec * flxdec, GstByteReader * reader, ++ GstByteWriter * writer, gint scale); ++static gboolean flx_decode_brun (GstFlxDec * flxdec, ++ GstByteReader * reader, GstByteWriter * writer); ++static gboolean flx_decode_delta_fli (GstFlxDec * flxdec, ++ GstByteReader * reader, GstByteWriter * writer); ++static gboolean flx_decode_delta_flc (GstFlxDec * flxdec, ++ GstByteReader * reader, GstByteWriter * writer); + + #define rndalign(off) ((off) + ((off) & 1)) + +@@ -204,57 +210,59 @@ gst_flxdec_sink_event_handler (GstPad * pad, GstObject * parent, + } + + static gboolean +-flx_decode_chunks (GstFlxDec * flxdec, gulong count, guchar * data, +- guchar * dest) ++flx_decode_chunks (GstFlxDec * flxdec, gulong n_chunks, GstByteReader * reader, ++ GstByteWriter * writer) + { +- FlxFrameChunk *hdr; + gboolean ret = TRUE; + +- g_return_val_if_fail (data != NULL, FALSE); +- +- while (count--) { +- hdr = (FlxFrameChunk *) data; +- FLX_FRAME_CHUNK_FIX_ENDIANNESS (hdr); +- data += FlxFrameChunkSize; ++ while (n_chunks--) { ++ GstByteReader chunk; ++ guint32 size; ++ guint16 type; ++ ++ if (!gst_byte_reader_get_uint32_le (reader, &size)) ++ goto parse_error; ++ if (!gst_byte_reader_get_uint16_le (reader, &type)) ++ goto parse_error; ++ GST_LOG_OBJECT (flxdec, "chunk has type 0x%02x size %d", type, size); ++ ++ if (!gst_byte_reader_get_sub_reader (reader, &chunk, ++ size - FlxFrameChunkSize)) { ++ GST_ERROR_OBJECT (flxdec, "Incorrect size in the chunk header"); ++ goto error; ++ } + +- switch (hdr->id) { ++ switch (type) { + case FLX_COLOR64: +- flx_decode_color (flxdec, data, dest, 2); +- data += rndalign (hdr->size) - FlxFrameChunkSize; ++ ret = flx_decode_color (flxdec, &chunk, writer, 2); + break; + + case FLX_COLOR256: +- flx_decode_color (flxdec, data, dest, 0); +- data += rndalign (hdr->size) - FlxFrameChunkSize; ++ ret = flx_decode_color (flxdec, &chunk, writer, 0); + break; + + case FLX_BRUN: +- ret = flx_decode_brun (flxdec, data, dest); +- data += rndalign (hdr->size) - FlxFrameChunkSize; ++ ret = flx_decode_brun (flxdec, &chunk, writer); + break; + + case FLX_LC: +- ret = flx_decode_delta_fli (flxdec, data, dest); +- data += rndalign (hdr->size) - FlxFrameChunkSize; ++ ret = flx_decode_delta_fli (flxdec, &chunk, writer); + break; + + case FLX_SS2: +- ret = flx_decode_delta_flc (flxdec, data, dest); +- data += rndalign (hdr->size) - FlxFrameChunkSize; ++ ret = flx_decode_delta_flc (flxdec, &chunk, writer); + break; + + case FLX_BLACK: +- memset (dest, 0, flxdec->size); ++ ret = gst_byte_writer_fill (writer, 0, flxdec->size); + break; + + case FLX_MINI: +- data += rndalign (hdr->size) - FlxFrameChunkSize; + break; + + default: +- GST_WARNING ("Unimplented chunk type: 0x%02x size: %d - skipping", +- hdr->id, hdr->size); +- data += rndalign (hdr->size) - FlxFrameChunkSize; ++ GST_WARNING ("Unimplemented chunk type: 0x%02x size: %d - skipping", ++ type, size); + break; + } + +@@ -263,43 +271,60 @@ flx_decode_chunks (GstFlxDec * flxdec, gulong count, guchar * data, + } + + return ret; ++ ++parse_error: ++ GST_ERROR_OBJECT (flxdec, "Failed to decode chunk"); ++error: ++ return FALSE; + } + + +-static void +-flx_decode_color (GstFlxDec * flxdec, guchar * data, guchar * dest, gint scale) ++static gboolean ++flx_decode_color (GstFlxDec * flxdec, GstByteReader * reader, ++ GstByteWriter * writer, gint scale) + { +- guint packs, count, indx; ++ guint8 count, indx; ++ guint16 packs; + +- g_return_if_fail (flxdec != NULL); +- +- packs = (data[0] + (data[1] << 8)); +- +- data += 2; ++ if (!gst_byte_reader_get_uint16_le (reader, &packs)) ++ goto error; + indx = 0; + +- GST_LOG ("GstFlxDec: cmap packs: %d", packs); ++ GST_LOG ("GstFlxDec: cmap packs: %d", (guint) packs); + while (packs--) { ++ const guint8 *data; ++ guint16 actual_count; ++ + /* color map index + skip count */ +- indx += *data++; ++ if (!gst_byte_reader_get_uint8 (reader, &indx)) ++ goto error; + + /* number of rgb triplets */ +- count = *data++ & 0xff; +- if (count == 0) +- count = 256; ++ if (!gst_byte_reader_get_uint8 (reader, &count)) ++ goto error; + +- GST_LOG ("GstFlxDec: cmap count: %d (indx: %d)", count, indx); +- flx_set_palette_vector (flxdec->converter, indx, count, data, scale); ++ actual_count = count == 0 ? 256 : count; + +- data += (count * 3); ++ if (!gst_byte_reader_get_data (reader, count * 3, &data)) ++ goto error; ++ ++ GST_LOG_OBJECT (flxdec, "cmap count: %d (indx: %d)", actual_count, indx); ++ flx_set_palette_vector (flxdec->converter, indx, actual_count, ++ (guchar *) data, scale); + } ++ ++ return TRUE; ++ ++error: ++ GST_ERROR_OBJECT (flxdec, "Error decoding color palette"); ++ return FALSE; + } + + static gboolean +-flx_decode_brun (GstFlxDec * flxdec, guchar * data, guchar * dest) ++flx_decode_brun (GstFlxDec * flxdec, GstByteReader * reader, ++ GstByteWriter * writer) + { +- gulong count, lines, row; +- guchar x; ++ gulong lines, row; + + g_return_val_if_fail (flxdec != NULL, FALSE); + +@@ -310,82 +335,125 @@ flx_decode_brun (GstFlxDec * flxdec, guchar * data, guchar * dest) + * contain more then 255 RLE packets. we use the frame + * width instead. + */ +- data++; ++ if (!gst_byte_reader_skip (reader, 1)) ++ goto error; + + row = flxdec->hdr.width; + while (row) { +- count = *data++; ++ gint8 count; ++ ++ if (!gst_byte_reader_get_int8 (reader, &count)) ++ goto error; ++ ++ if (count <= 0) { ++ const guint8 *data; + +- if (count > 0x7f) { + /* literal run */ +- count = 0x100 - count; +- if ((glong) row - (glong) count < 0) { +- GST_ERROR_OBJECT (flxdec, "Invalid BRUN packet detected."); ++ count = ABS (count); ++ ++ GST_LOG_OBJECT (flxdec, "have literal run of size %d", count); ++ ++ if (count > row) { ++ GST_ERROR_OBJECT (flxdec, "Invalid BRUN line detected. " ++ "bytes to write exceeds the end of the row"); + return FALSE; + } + row -= count; + +- while (count--) +- *dest++ = *data++; +- ++ if (!gst_byte_reader_get_data (reader, count, &data)) ++ goto error; ++ if (!gst_byte_writer_put_data (writer, data, count)) ++ goto error; + } else { +- if ((glong) row - (glong) count < 0) { +- GST_ERROR_OBJECT (flxdec, "Invalid BRUN packet detected."); ++ guint8 x; ++ ++ GST_LOG_OBJECT (flxdec, "have replicate run of size %d", count); ++ ++ if (count > row) { ++ GST_ERROR_OBJECT (flxdec, "Invalid BRUN packet detected." ++ "bytes to write exceeds the end of the row"); + return FALSE; + } + + /* replicate run */ + row -= count; +- x = *data++; + +- while (count--) +- *dest++ = x; ++ if (!gst_byte_reader_get_uint8 (reader, &x)) ++ goto error; ++ if (!gst_byte_writer_fill (writer, x, count)) ++ goto error; + } + } + } + + return TRUE; ++ ++error: ++ GST_ERROR_OBJECT (flxdec, "Failed to decode BRUN packet"); ++ return FALSE; + } + + static gboolean +-flx_decode_delta_fli (GstFlxDec * flxdec, guchar * data, guchar * dest) ++flx_decode_delta_fli (GstFlxDec * flxdec, GstByteReader * reader, ++ GstByteWriter * writer) + { +- gulong count, packets, lines, start_line; +- guchar *start_p, x; ++ guint16 start_line, lines; ++ guint line_start_i; + + g_return_val_if_fail (flxdec != NULL, FALSE); + g_return_val_if_fail (flxdec->delta_data != NULL, FALSE); + + /* use last frame for delta */ +- memcpy (dest, flxdec->delta_data, flxdec->size); ++ if (!gst_byte_writer_put_data (writer, flxdec->delta_data, flxdec->size)) ++ goto error; ++ ++ if (!gst_byte_reader_get_uint16_le (reader, &start_line)) ++ goto error; ++ if (!gst_byte_reader_get_uint16_le (reader, &lines)) ++ goto error; ++ GST_LOG_OBJECT (flxdec, "height %d start line %d line count %d", ++ flxdec->hdr.height, start_line, lines); + +- start_line = (data[0] + (data[1] << 8)); +- lines = (data[2] + (data[3] << 8)); + if (start_line + lines > flxdec->hdr.height) { + GST_ERROR_OBJECT (flxdec, "Invalid FLI packet detected. too many lines."); + return FALSE; + } +- data += 4; + +- /* start position of delta */ +- dest += (flxdec->hdr.width * start_line); +- start_p = dest; ++ line_start_i = flxdec->hdr.width * start_line; ++ if (!gst_byte_writer_set_pos (writer, line_start_i)) ++ goto error; + + while (lines--) { ++ guint8 packets; ++ + /* packet count */ +- packets = *data++; ++ if (!gst_byte_reader_get_uint8 (reader, &packets)) ++ goto error; ++ GST_LOG_OBJECT (flxdec, "have %d packets", packets); + + while (packets--) { + /* skip count */ +- guchar skip = *data++; +- dest += skip; ++ guint8 skip; ++ gint8 count; ++ if (!gst_byte_reader_get_uint8 (reader, &skip)) ++ goto error; ++ ++ /* skip bytes */ ++ if (!gst_byte_writer_set_pos (writer, ++ gst_byte_writer_get_pos (writer) + skip)) ++ goto error; + + /* RLE count */ +- count = *data++; ++ if (!gst_byte_reader_get_int8 (reader, &count)) ++ goto error; ++ ++ if (count < 0) { ++ guint8 x; + +- if (count > 0x7f) { + /* literal run */ +- count = 0x100 - count; ++ count = ABS (count); ++ GST_LOG_OBJECT (flxdec, "have literal run of size %d at offset %d", ++ count, skip); + + if (skip + count > flxdec->hdr.width) { + GST_ERROR_OBJECT (flxdec, "Invalid FLI packet detected. " +@@ -393,11 +461,16 @@ flx_decode_delta_fli (GstFlxDec * flxdec, guchar * data, guchar * dest) + return FALSE; + } + +- x = *data++; +- while (count--) +- *dest++ = x; +- ++ if (!gst_byte_reader_get_uint8 (reader, &x)) ++ goto error; ++ if (!gst_byte_writer_fill (writer, x, count)) ++ goto error; + } else { ++ const guint8 *data; ++ ++ GST_LOG_OBJECT (flxdec, "have replicate run of size %d at offset %d", ++ count, skip); ++ + if (skip + count > flxdec->hdr.width) { + GST_ERROR_OBJECT (flxdec, "Invalid FLI packet detected. " + "line too long."); +@@ -405,45 +478,60 @@ flx_decode_delta_fli (GstFlxDec * flxdec, guchar * data, guchar * dest) + } + + /* replicate run */ +- while (count--) +- *dest++ = *data++; ++ if (!gst_byte_reader_get_data (reader, count, &data)) ++ goto error; ++ if (!gst_byte_writer_put_data (writer, data, count)) ++ goto error; + } + } +- start_p += flxdec->hdr.width; +- dest = start_p; ++ line_start_i += flxdec->hdr.width; ++ if (!gst_byte_writer_set_pos (writer, line_start_i)) ++ goto error; + } + + return TRUE; ++ ++error: ++ GST_ERROR_OBJECT (flxdec, "Failed to decode FLI packet"); ++ return FALSE; + } + + static gboolean +-flx_decode_delta_flc (GstFlxDec * flxdec, guchar * data, guchar * dest) ++flx_decode_delta_flc (GstFlxDec * flxdec, GstByteReader * reader, ++ GstByteWriter * writer) + { +- gulong count, lines, start_l, opcode; +- guchar *start_p; ++ guint16 lines, start_l; + + g_return_val_if_fail (flxdec != NULL, FALSE); + g_return_val_if_fail (flxdec->delta_data != NULL, FALSE); + + /* use last frame for delta */ +- memcpy (dest, flxdec->delta_data, flxdec->size); ++ if (!gst_byte_writer_put_data (writer, flxdec->delta_data, flxdec->size)) ++ goto error; ++ if (!gst_byte_reader_get_uint16_le (reader, &lines)) ++ goto error; + +- lines = (data[0] + (data[1] << 8)); + if (lines > flxdec->hdr.height) { + GST_ERROR_OBJECT (flxdec, "Invalid FLC packet detected. too many lines."); + return FALSE; + } +- data += 2; + +- start_p = dest; + start_l = lines; + + while (lines) { +- dest = start_p + (flxdec->hdr.width * (start_l - lines)); ++ guint16 opcode; ++ ++ if (!gst_byte_writer_set_pos (writer, ++ flxdec->hdr.width * (start_l - lines))) ++ goto error; + + /* process opcode(s) */ +- while ((opcode = (data[0] + (data[1] << 8))) & 0xc000) { +- data += 2; ++ while (TRUE) { ++ if (!gst_byte_reader_get_uint16_le (reader, &opcode)) ++ goto error; ++ if ((opcode & 0xc000) == 0) ++ break; ++ + if ((opcode & 0xc000) == 0xc000) { + /* line skip count */ + gulong skip = (0x10000 - opcode); +@@ -453,27 +541,44 @@ flx_decode_delta_flc (GstFlxDec * flxdec, guchar * data, guchar * dest) + return FALSE; + } + start_l += skip; +- dest += flxdec->hdr.width * skip; ++ if (!gst_byte_writer_set_pos (writer, ++ gst_byte_writer_get_pos (writer) + flxdec->hdr.width * skip)) ++ goto error; + } else { + /* last pixel */ +- dest += flxdec->hdr.width; +- *dest++ = (opcode & 0xff); ++ if (!gst_byte_writer_set_pos (writer, ++ gst_byte_writer_get_pos (writer) + flxdec->hdr.width)) ++ goto error; ++ if (!gst_byte_writer_put_uint8 (writer, opcode & 0xff)) ++ goto error; + } + } +- data += 2; + + /* last opcode is the packet count */ ++ GST_LOG_OBJECT (flxdec, "have %d packets", opcode); + while (opcode--) { + /* skip count */ +- guchar skip = *data++; +- dest += skip; ++ guint8 skip; ++ gint8 count; ++ ++ if (!gst_byte_reader_get_uint8 (reader, &skip)) ++ goto error; ++ if (!gst_byte_writer_set_pos (writer, ++ gst_byte_writer_get_pos (writer) + skip)) ++ goto error; + + /* RLE count */ +- count = *data++; ++ if (!gst_byte_reader_get_int8 (reader, &count)) ++ goto error; ++ ++ if (count < 0) { ++ guint16 x; + +- if (count > 0x7f) { + /* replicate word run */ +- count = 0x100 - count; ++ count = ABS (count); ++ ++ GST_LOG_OBJECT (flxdec, "have replicate run of size %d at offset %d", ++ count, skip); + + if (skip + count > flxdec->hdr.width) { + GST_ERROR_OBJECT (flxdec, "Invalid FLC packet detected. " +@@ -481,22 +586,31 @@ flx_decode_delta_flc (GstFlxDec * flxdec, guchar * data, guchar * dest) + return FALSE; + } + ++ if (!gst_byte_reader_get_uint16_le (reader, &x)) ++ goto error; ++ + while (count--) { +- *dest++ = data[0]; +- *dest++ = data[1]; ++ if (!gst_byte_writer_put_uint16_le (writer, x)) { ++ goto error; ++ } + } +- data += 2; + } else { ++ GST_LOG_OBJECT (flxdec, "have literal run of size %d at offset %d", ++ count, skip); ++ + if (skip + count > flxdec->hdr.width) { + GST_ERROR_OBJECT (flxdec, "Invalid FLC packet detected. " + "line too long."); + return FALSE; + } + +- /* literal word run */ + while (count--) { +- *dest++ = *data++; +- *dest++ = *data++; ++ guint16 x; ++ ++ if (!gst_byte_reader_get_uint16_le (reader, &x)) ++ goto error; ++ if (!gst_byte_writer_put_uint16_le (writer, x)) ++ goto error; + } + } + } +@@ -504,13 +618,91 @@ flx_decode_delta_flc (GstFlxDec * flxdec, guchar * data, guchar * dest) + } + + return TRUE; ++ ++error: ++ GST_ERROR_OBJECT (flxdec, "Failed to decode FLI packet"); ++ return FALSE; ++} ++ ++static gboolean ++_read_flx_header (GstFlxDec * flxdec, GstByteReader * reader, FlxHeader * flxh) ++{ ++ memset (flxh, 0, sizeof (*flxh)); ++ ++ if (!gst_byte_reader_get_uint32_le (reader, &flxh->size)) ++ goto error; ++ if (flxh->size < FlxHeaderSize) { ++ GST_ERROR_OBJECT (flxdec, "Invalid file size in the header"); ++ return FALSE; ++ } ++ ++ if (!gst_byte_reader_get_uint16_le (reader, &flxh->type)) ++ goto error; ++ if (!gst_byte_reader_get_uint16_le (reader, &flxh->frames)) ++ goto error; ++ if (!gst_byte_reader_get_uint16_le (reader, &flxh->width)) ++ goto error; ++ if (!gst_byte_reader_get_uint16_le (reader, &flxh->height)) ++ goto error; ++ if (!gst_byte_reader_get_uint16_le (reader, &flxh->depth)) ++ goto error; ++ if (!gst_byte_reader_get_uint16_le (reader, &flxh->flags)) ++ goto error; ++ if (!gst_byte_reader_get_uint32_le (reader, &flxh->speed)) ++ goto error; ++ if (!gst_byte_reader_skip (reader, 2)) /* reserved */ ++ goto error; ++ /* FLC */ ++ if (!gst_byte_reader_get_uint32_le (reader, &flxh->created)) ++ goto error; ++ if (!gst_byte_reader_get_uint32_le (reader, &flxh->creator)) ++ goto error; ++ if (!gst_byte_reader_get_uint32_le (reader, &flxh->updated)) ++ goto error; ++ if (!gst_byte_reader_get_uint32_le (reader, &flxh->updater)) ++ goto error; ++ if (!gst_byte_reader_get_uint16_le (reader, &flxh->aspect_dx)) ++ goto error; ++ if (!gst_byte_reader_get_uint16_le (reader, &flxh->aspect_dy)) ++ goto error; ++ /* EGI */ ++ if (!gst_byte_reader_get_uint16_le (reader, &flxh->ext_flags)) ++ goto error; ++ if (!gst_byte_reader_get_uint16_le (reader, &flxh->keyframes)) ++ goto error; ++ if (!gst_byte_reader_get_uint16_le (reader, &flxh->totalframes)) ++ goto error; ++ if (!gst_byte_reader_get_uint32_le (reader, &flxh->req_memory)) ++ goto error; ++ if (!gst_byte_reader_get_uint16_le (reader, &flxh->max_regions)) ++ goto error; ++ if (!gst_byte_reader_get_uint16_le (reader, &flxh->transp_num)) ++ goto error; ++ if (!gst_byte_reader_skip (reader, 24)) /* reserved */ ++ goto error; ++ /* FLC */ ++ if (!gst_byte_reader_get_uint32_le (reader, &flxh->oframe1)) ++ goto error; ++ if (!gst_byte_reader_get_uint32_le (reader, &flxh->oframe2)) ++ goto error; ++ if (!gst_byte_reader_skip (reader, 40)) /* reserved */ ++ goto error; ++ ++ return TRUE; ++ ++error: ++ GST_ERROR_OBJECT (flxdec, "Error reading file header"); ++ return FALSE; + } + + static GstFlowReturn + gst_flxdec_chain (GstPad * pad, GstObject * parent, GstBuffer * buf) + { ++ GstByteReader reader; ++ GstBuffer *input; ++ GstMapInfo map_info; + GstCaps *caps; +- guint avail; ++ guint available; + GstFlowReturn res = GST_FLOW_OK; + + GstFlxDec *flxdec; +@@ -521,31 +713,50 @@ gst_flxdec_chain (GstPad * pad, GstObject * parent, GstBuffer * buf) + g_return_val_if_fail (flxdec != NULL, GST_FLOW_ERROR); + + gst_adapter_push (flxdec->adapter, buf); +- avail = gst_adapter_available (flxdec->adapter); ++ available = gst_adapter_available (flxdec->adapter); ++ input = gst_adapter_get_buffer (flxdec->adapter, available); ++ if (!gst_buffer_map (input, &map_info, GST_MAP_READ)) { ++ GST_ELEMENT_ERROR (flxdec, STREAM, DECODE, ++ ("%s", "Failed to map buffer"), (NULL)); ++ goto error; ++ } ++ gst_byte_reader_init (&reader, map_info.data, map_info.size); + + if (flxdec->state == GST_FLXDEC_READ_HEADER) { +- if (avail >= FlxHeaderSize) { +- const guint8 *data = gst_adapter_map (flxdec->adapter, FlxHeaderSize); ++ if (available >= FlxHeaderSize) { ++ GstByteReader header; + GstCaps *templ; + +- memcpy ((gchar *) & flxdec->hdr, data, FlxHeaderSize); +- FLX_HDR_FIX_ENDIANNESS (&(flxdec->hdr)); +- gst_adapter_unmap (flxdec->adapter); ++ if (!gst_byte_reader_get_sub_reader (&reader, &header, FlxHeaderSize)) { ++ GST_ELEMENT_ERROR (flxdec, STREAM, DECODE, ++ ("%s", "Could not read header"), (NULL)); ++ goto unmap_input_error; ++ } + gst_adapter_flush (flxdec->adapter, FlxHeaderSize); ++ available -= FlxHeaderSize; ++ ++ if (!_read_flx_header (flxdec, &header, &flxdec->hdr)) { ++ GST_ELEMENT_ERROR (flxdec, STREAM, DECODE, ++ ("%s", "Failed to parse header"), (NULL)); ++ goto unmap_input_error; ++ } + + flxh = &flxdec->hdr; + + /* check header */ + if (flxh->type != FLX_MAGICHDR_FLI && +- flxh->type != FLX_MAGICHDR_FLC && flxh->type != FLX_MAGICHDR_FLX) +- goto wrong_type; ++ flxh->type != FLX_MAGICHDR_FLC && flxh->type != FLX_MAGICHDR_FLX) { ++ GST_ELEMENT_ERROR (flxdec, STREAM, WRONG_TYPE, (NULL), ++ ("not a flx file (type %x)", flxh->type)); ++ goto unmap_input_error; ++ } + +- GST_LOG ("size : %d", flxh->size); +- GST_LOG ("frames : %d", flxh->frames); +- GST_LOG ("width : %d", flxh->width); +- GST_LOG ("height : %d", flxh->height); +- GST_LOG ("depth : %d", flxh->depth); +- GST_LOG ("speed : %d", flxh->speed); ++ GST_INFO_OBJECT (flxdec, "size : %d", flxh->size); ++ GST_INFO_OBJECT (flxdec, "frames : %d", flxh->frames); ++ GST_INFO_OBJECT (flxdec, "width : %d", flxh->width); ++ GST_INFO_OBJECT (flxdec, "height : %d", flxh->height); ++ GST_INFO_OBJECT (flxdec, "depth : %d", flxh->depth); ++ GST_INFO_OBJECT (flxdec, "speed : %d", flxh->speed); + + flxdec->next_time = 0; + +@@ -573,18 +784,32 @@ gst_flxdec_chain (GstPad * pad, GstObject * parent, GstBuffer * buf) + gst_pad_set_caps (flxdec->srcpad, caps); + gst_caps_unref (caps); + +- if (flxh->depth <= 8) +- flxdec->converter = +- flx_colorspace_converter_new (flxh->width, flxh->height); ++ /* zero means 8 */ ++ if (flxh->depth == 0) ++ flxh->depth = 8; ++ ++ if (flxh->depth != 8) { ++ GST_ELEMENT_ERROR (flxdec, STREAM, WRONG_TYPE, ++ ("%s", "Don't know how to decode non 8 bit depth streams"), (NULL)); ++ goto unmap_input_error; ++ } ++ ++ flxdec->converter = ++ flx_colorspace_converter_new (flxh->width, flxh->height); + + if (flxh->type == FLX_MAGICHDR_FLC || flxh->type == FLX_MAGICHDR_FLX) { +- GST_LOG ("(FLC) aspect_dx : %d", flxh->aspect_dx); +- GST_LOG ("(FLC) aspect_dy : %d", flxh->aspect_dy); +- GST_LOG ("(FLC) oframe1 : 0x%08x", flxh->oframe1); +- GST_LOG ("(FLC) oframe2 : 0x%08x", flxh->oframe2); ++ GST_INFO_OBJECT (flxdec, "(FLC) aspect_dx : %d", flxh->aspect_dx); ++ GST_INFO_OBJECT (flxdec, "(FLC) aspect_dy : %d", flxh->aspect_dy); ++ GST_INFO_OBJECT (flxdec, "(FLC) oframe1 : 0x%08x", flxh->oframe1); ++ GST_INFO_OBJECT (flxdec, "(FLC) oframe2 : 0x%08x", flxh->oframe2); + } + + flxdec->size = ((guint) flxh->width * (guint) flxh->height); ++ if (flxdec->size >= G_MAXSIZE / 4) { ++ GST_ELEMENT_ERROR (flxdec, STREAM, DECODE, ++ ("%s", "Cannot allocate required memory"), (NULL)); ++ goto unmap_input_error; ++ } + + /* create delta and output frame */ + flxdec->frame_data = g_malloc (flxdec->size); +@@ -596,55 +821,66 @@ gst_flxdec_chain (GstPad * pad, GstObject * parent, GstBuffer * buf) + GstBuffer *out; + + /* while we have enough data in the adapter */ +- while (avail >= FlxFrameChunkSize && res == GST_FLOW_OK) { +- FlxFrameChunk flxfh; +- guchar *chunk; +- const guint8 *data; +- GstMapInfo map; +- +- chunk = NULL; +- data = gst_adapter_map (flxdec->adapter, FlxFrameChunkSize); +- memcpy (&flxfh, data, FlxFrameChunkSize); +- FLX_FRAME_CHUNK_FIX_ENDIANNESS (&flxfh); +- gst_adapter_unmap (flxdec->adapter); +- +- switch (flxfh.id) { +- case FLX_FRAME_TYPE: +- /* check if we have the complete frame */ +- if (avail < flxfh.size) +- goto need_more_data; +- +- /* flush header */ +- gst_adapter_flush (flxdec->adapter, FlxFrameChunkSize); +- +- chunk = gst_adapter_take (flxdec->adapter, +- flxfh.size - FlxFrameChunkSize); +- FLX_FRAME_TYPE_FIX_ENDIANNESS ((FlxFrameType *) chunk); +- if (((FlxFrameType *) chunk)->chunks == 0) +- break; ++ while (available >= FlxFrameChunkSize && res == GST_FLOW_OK) { ++ guint32 size; ++ guint16 type; + +- /* create 32 bits output frame */ +-// res = gst_pad_alloc_buffer_and_set_caps (flxdec->srcpad, +-// GST_BUFFER_OFFSET_NONE, +-// flxdec->size * 4, GST_PAD_CAPS (flxdec->srcpad), &out); +-// if (res != GST_FLOW_OK) +-// break; ++ if (!gst_byte_reader_get_uint32_le (&reader, &size)) ++ goto parse_error; ++ if (available < size) ++ goto need_more_data; + +- out = gst_buffer_new_and_alloc (flxdec->size * 4); ++ available -= size; ++ gst_adapter_flush (flxdec->adapter, size); ++ ++ if (!gst_byte_reader_get_uint16_le (&reader, &type)) ++ goto parse_error; ++ ++ switch (type) { ++ case FLX_FRAME_TYPE:{ ++ GstByteReader chunks; ++ GstByteWriter writer; ++ guint16 n_chunks; ++ GstMapInfo map; ++ ++ GST_LOG_OBJECT (flxdec, "Have frame type 0x%02x of size %d", type, ++ size); ++ ++ if (!gst_byte_reader_get_sub_reader (&reader, &chunks, ++ size - FlxFrameChunkSize)) ++ goto parse_error; ++ ++ if (!gst_byte_reader_get_uint16_le (&chunks, &n_chunks)) ++ goto parse_error; ++ GST_LOG_OBJECT (flxdec, "Have %d chunks", n_chunks); ++ ++ if (n_chunks == 0) ++ break; ++ if (!gst_byte_reader_skip (&chunks, 8)) /* reserved */ ++ goto parse_error; ++ ++ gst_byte_writer_init_with_data (&writer, flxdec->frame_data, ++ flxdec->size, TRUE); + + /* decode chunks */ +- if (!flx_decode_chunks (flxdec, +- ((FlxFrameType *) chunk)->chunks, +- chunk + FlxFrameTypeSize, flxdec->frame_data)) { ++ if (!flx_decode_chunks (flxdec, n_chunks, &chunks, &writer)) { + GST_ELEMENT_ERROR (flxdec, STREAM, DECODE, + ("%s", "Could not decode chunk"), NULL); +- return GST_FLOW_ERROR; ++ goto unmap_input_error; + } ++ gst_byte_writer_reset (&writer); + + /* save copy of the current frame for possible delta. */ + memcpy (flxdec->delta_data, flxdec->frame_data, flxdec->size); + +- gst_buffer_map (out, &map, GST_MAP_WRITE); ++ out = gst_buffer_new_and_alloc (flxdec->size * 4); ++ if (!gst_buffer_map (out, &map, GST_MAP_WRITE)) { ++ GST_ELEMENT_ERROR (flxdec, STREAM, DECODE, ++ ("%s", "Could not map output buffer"), NULL); ++ gst_buffer_unref (out); ++ goto unmap_input_error; ++ } ++ + /* convert current frame. */ + flx_colorspace_convert (flxdec->converter, flxdec->frame_data, + map.data); +@@ -655,30 +891,32 @@ gst_flxdec_chain (GstPad * pad, GstObject * parent, GstBuffer * buf) + + res = gst_pad_push (flxdec->srcpad, out); + break; ++ } + default: +- /* check if we have the complete frame */ +- if (avail < flxfh.size) +- goto need_more_data; +- +- gst_adapter_flush (flxdec->adapter, flxfh.size); ++ GST_DEBUG_OBJECT (flxdec, "Unknown frame type 0x%02x, skipping %d", ++ type, size); ++ if (!gst_byte_reader_skip (&reader, size - FlxFrameChunkSize)) ++ goto parse_error; + break; + } +- +- g_free (chunk); +- +- avail = gst_adapter_available (flxdec->adapter); + } + } ++ ++ gst_buffer_unmap (input, &map_info); ++ gst_buffer_unref (input); ++ + need_more_data: + return res; + + /* ERRORS */ +-wrong_type: +- { +- GST_ELEMENT_ERROR (flxdec, STREAM, WRONG_TYPE, (NULL), +- ("not a flx file (type %x)", flxh->type)); +- return GST_FLOW_ERROR; +- } ++parse_error: ++ GST_ELEMENT_ERROR (flxdec, STREAM, DECODE, ++ ("%s", "Failed to parse stream"), (NULL)); ++unmap_input_error: ++ gst_buffer_unmap (input, &map_info); ++ gst_buffer_unref (input); ++error: ++ return GST_FLOW_ERROR; + } + + static GstStateChangeReturn +diff --git a/gst/flx/gstflxdec.h b/gst/flx/gstflxdec.h +index 3f9a0aa..4fd8dfd 100644 +--- a/gst/flx/gstflxdec.h ++++ b/gst/flx/gstflxdec.h +@@ -23,6 +23,8 @@ + #include <gst/gst.h> + + #include <gst/base/gstadapter.h> ++#include <gst/base/gstbytereader.h> ++#include <gst/base/gstbytewriter.h> + #include "flx_color.h" + + G_BEGIN_DECLS +@@ -45,7 +47,7 @@ struct _GstFlxDec { + + guint8 *delta_data, *frame_data; + GstAdapter *adapter; +- gulong size; ++ gsize size; + GstFlxDecState state; + gint64 frame_time; + gint64 next_time; +-- +2.10.2 + diff --git a/gnu/packages/patches/gst-plugins-good-fix-invalid-read.patch b/gnu/packages/patches/gst-plugins-good-fix-invalid-read.patch new file mode 100644 index 0000000000..1daaa2ae15 --- /dev/null +++ b/gnu/packages/patches/gst-plugins-good-fix-invalid-read.patch @@ -0,0 +1,37 @@ +Fixes upstream bug #774897 (flxdec: Unreferences itself one time too many on +invalid files): + +https://bugzilla.gnome.org/show_bug.cgi?id=774897 + +Patch copied from upstream source repository: + +https://cgit.freedesktop.org/gstreamer/gst-plugins-good/commit/?id=b31c504645a814c59d91d49e4fe218acaf93f4ca + +From b31c504645a814c59d91d49e4fe218acaf93f4ca Mon Sep 17 00:00:00 2001 +From: =?UTF-8?q?Sebastian=20Dr=C3=B6ge?= <sebastian@centricular.com> +Date: Wed, 23 Nov 2016 11:20:49 +0200 +Subject: [PATCH] flxdec: Don't unref() parent in the chain function + +We don't own the reference here, it is owned by the caller and given to +us for the scope of this function. Leftover mistake from 0.10 porting. + +https://bugzilla.gnome.org/show_bug.cgi?id=774897 +--- + gst/flx/gstflxdec.c | 1 - + 1 file changed, 1 deletion(-) + +diff --git a/gst/flx/gstflxdec.c b/gst/flx/gstflxdec.c +index e675c99..a237976 100644 +--- a/gst/flx/gstflxdec.c ++++ b/gst/flx/gstflxdec.c +@@ -677,7 +677,6 @@ wrong_type: + { + GST_ELEMENT_ERROR (flxdec, STREAM, WRONG_TYPE, (NULL), + ("not a flx file (type %x)", flxh->type)); +- gst_object_unref (flxdec); + return GST_FLOW_ERROR; + } + } +-- +2.10.2 + diff --git a/gnu/packages/patches/gst-plugins-good-fix-signedness.patch b/gnu/packages/patches/gst-plugins-good-fix-signedness.patch new file mode 100644 index 0000000000..a3e20e19dd --- /dev/null +++ b/gnu/packages/patches/gst-plugins-good-fix-signedness.patch @@ -0,0 +1,58 @@ +This is a followup fix for upstream bug #774834 (flic decoder: Buffer overflow +in flx_decode_delta_fli): + +https://bugzilla.gnome.org/show_bug.cgi?id=774834#c2 + +Patch copied from upstream source repository: + +https://cgit.freedesktop.org/gstreamer/gst-plugins-good/commit/?id=1ab2b26193861b124426e2f8eb62b75b59ec5488 + +From 1ab2b26193861b124426e2f8eb62b75b59ec5488 Mon Sep 17 00:00:00 2001 +From: Matthew Waters <matthew@centricular.com> +Date: Tue, 22 Nov 2016 23:46:00 +1100 +Subject: [PATCH] flxdec: fix some warnings comparing unsigned < 0 +MIME-Version: 1.0 +Content-Type: text/plain; charset=UTF-8 +Content-Transfer-Encoding: 8bit + +bf43f44fcfada5ec4a3ce60cb374340486fe9fac was comparing an unsigned +expression to be < 0 which was always false. + +gstflxdec.c: In function ‘flx_decode_brun’: +gstflxdec.c:322:33: warning: comparison of unsigned expression < 0 is always false [-Wtype-limits] + if ((glong) row - count < 0) { + ^ +gstflxdec.c:332:33: warning: comparison of unsigned expression < 0 is always false [-Wtype-limits] + if ((glong) row - count < 0) { + ^ + +https://bugzilla.gnome.org/show_bug.cgi?id=774834 +--- + gst/flx/gstflxdec.c | 4 ++-- + 1 file changed, 2 insertions(+), 2 deletions(-) + +diff --git a/gst/flx/gstflxdec.c b/gst/flx/gstflxdec.c +index d51a8e6..e675c99 100644 +--- a/gst/flx/gstflxdec.c ++++ b/gst/flx/gstflxdec.c +@@ -319,7 +319,7 @@ flx_decode_brun (GstFlxDec * flxdec, guchar * data, guchar * dest) + if (count > 0x7f) { + /* literal run */ + count = 0x100 - count; +- if ((glong) row - count < 0) { ++ if ((glong) row - (glong) count < 0) { + GST_ERROR_OBJECT (flxdec, "Invalid BRUN packet detected."); + return FALSE; + } +@@ -329,7 +329,7 @@ flx_decode_brun (GstFlxDec * flxdec, guchar * data, guchar * dest) + *dest++ = *data++; + + } else { +- if ((glong) row - count < 0) { ++ if ((glong) row - (glong) count < 0) { + GST_ERROR_OBJECT (flxdec, "Invalid BRUN packet detected."); + return FALSE; + } +-- +2.10.2 + diff --git a/gnu/packages/patches/gst-plugins-good-flic-bounds-check.patch b/gnu/packages/patches/gst-plugins-good-flic-bounds-check.patch new file mode 100644 index 0000000000..f77dca2cd6 --- /dev/null +++ b/gnu/packages/patches/gst-plugins-good-flic-bounds-check.patch @@ -0,0 +1,319 @@ +Fix CVE-2016-{9634,9635,9636}. + +https://cve.mitre.org/cgi-bin/cvename.cgi?name=CVE-2016-9634 +https://cve.mitre.org/cgi-bin/cvename.cgi?name=CVE-2016-9635 +https://cve.mitre.org/cgi-bin/cvename.cgi?name=CVE-2016-9636 + +This fixes upstream bug #774834 (flic decoder: Buffer overflow in +flx_decode_delta_fli): + +https://bugzilla.gnome.org/show_bug.cgi?id=774834 + +Patch copied from upstream source repository: + +https://cgit.freedesktop.org/gstreamer/gst-plugins-good/commit/?id=2e203a79b7d9af4029307c1a845b3c148d5f5e62 + +From 2e203a79b7d9af4029307c1a845b3c148d5f5e62 Mon Sep 17 00:00:00 2001 +From: Matthew Waters <matthew@centricular.com> +Date: Tue, 22 Nov 2016 19:05:00 +1100 +Subject: [PATCH] flxdec: add some write bounds checking + +Without checking the bounds of the frame we are writing into, we can +write off the end of the destination buffer. + +https://scarybeastsecurity.blogspot.dk/2016/11/0day-exploit-advancing-exploitation.html + +https://bugzilla.gnome.org/show_bug.cgi?id=774834 +--- + gst/flx/gstflxdec.c | 116 +++++++++++++++++++++++++++++++++++++++++----------- + 1 file changed, 91 insertions(+), 25 deletions(-) + +diff --git a/gst/flx/gstflxdec.c b/gst/flx/gstflxdec.c +index 604be2f..d51a8e6 100644 +--- a/gst/flx/gstflxdec.c ++++ b/gst/flx/gstflxdec.c +@@ -74,9 +74,9 @@ static gboolean gst_flxdec_src_query_handler (GstPad * pad, GstObject * parent, + GstQuery * query); + + static void flx_decode_color (GstFlxDec *, guchar *, guchar *, gint); +-static void flx_decode_brun (GstFlxDec *, guchar *, guchar *); +-static void flx_decode_delta_fli (GstFlxDec *, guchar *, guchar *); +-static void flx_decode_delta_flc (GstFlxDec *, guchar *, guchar *); ++static gboolean flx_decode_brun (GstFlxDec *, guchar *, guchar *); ++static gboolean flx_decode_delta_fli (GstFlxDec *, guchar *, guchar *); ++static gboolean flx_decode_delta_flc (GstFlxDec *, guchar *, guchar *); + + #define rndalign(off) ((off) + ((off) & 1)) + +@@ -203,13 +203,14 @@ gst_flxdec_sink_event_handler (GstPad * pad, GstObject * parent, + return ret; + } + +-static void ++static gboolean + flx_decode_chunks (GstFlxDec * flxdec, gulong count, guchar * data, + guchar * dest) + { + FlxFrameChunk *hdr; ++ gboolean ret = TRUE; + +- g_return_if_fail (data != NULL); ++ g_return_val_if_fail (data != NULL, FALSE); + + while (count--) { + hdr = (FlxFrameChunk *) data; +@@ -228,17 +229,17 @@ flx_decode_chunks (GstFlxDec * flxdec, gulong count, guchar * data, + break; + + case FLX_BRUN: +- flx_decode_brun (flxdec, data, dest); ++ ret = flx_decode_brun (flxdec, data, dest); + data += rndalign (hdr->size) - FlxFrameChunkSize; + break; + + case FLX_LC: +- flx_decode_delta_fli (flxdec, data, dest); ++ ret = flx_decode_delta_fli (flxdec, data, dest); + data += rndalign (hdr->size) - FlxFrameChunkSize; + break; + + case FLX_SS2: +- flx_decode_delta_flc (flxdec, data, dest); ++ ret = flx_decode_delta_flc (flxdec, data, dest); + data += rndalign (hdr->size) - FlxFrameChunkSize; + break; + +@@ -256,7 +257,12 @@ flx_decode_chunks (GstFlxDec * flxdec, gulong count, guchar * data, + data += rndalign (hdr->size) - FlxFrameChunkSize; + break; + } ++ ++ if (!ret) ++ break; + } ++ ++ return ret; + } + + +@@ -289,13 +295,13 @@ flx_decode_color (GstFlxDec * flxdec, guchar * data, guchar * dest, gint scale) + } + } + +-static void ++static gboolean + flx_decode_brun (GstFlxDec * flxdec, guchar * data, guchar * dest) + { + gulong count, lines, row; + guchar x; + +- g_return_if_fail (flxdec != NULL); ++ g_return_val_if_fail (flxdec != NULL, FALSE); + + lines = flxdec->hdr.height; + while (lines--) { +@@ -313,12 +319,21 @@ flx_decode_brun (GstFlxDec * flxdec, guchar * data, guchar * dest) + if (count > 0x7f) { + /* literal run */ + count = 0x100 - count; ++ if ((glong) row - count < 0) { ++ GST_ERROR_OBJECT (flxdec, "Invalid BRUN packet detected."); ++ return FALSE; ++ } + row -= count; + + while (count--) + *dest++ = *data++; + + } else { ++ if ((glong) row - count < 0) { ++ GST_ERROR_OBJECT (flxdec, "Invalid BRUN packet detected."); ++ return FALSE; ++ } ++ + /* replicate run */ + row -= count; + x = *data++; +@@ -328,22 +343,28 @@ flx_decode_brun (GstFlxDec * flxdec, guchar * data, guchar * dest) + } + } + } ++ ++ return TRUE; + } + +-static void ++static gboolean + flx_decode_delta_fli (GstFlxDec * flxdec, guchar * data, guchar * dest) + { + gulong count, packets, lines, start_line; + guchar *start_p, x; + +- g_return_if_fail (flxdec != NULL); +- g_return_if_fail (flxdec->delta_data != NULL); ++ g_return_val_if_fail (flxdec != NULL, FALSE); ++ g_return_val_if_fail (flxdec->delta_data != NULL, FALSE); + + /* use last frame for delta */ + memcpy (dest, flxdec->delta_data, flxdec->size); + + start_line = (data[0] + (data[1] << 8)); + lines = (data[2] + (data[3] << 8)); ++ if (start_line + lines > flxdec->hdr.height) { ++ GST_ERROR_OBJECT (flxdec, "Invalid FLI packet detected. too many lines."); ++ return FALSE; ++ } + data += 4; + + /* start position of delta */ +@@ -356,7 +377,8 @@ flx_decode_delta_fli (GstFlxDec * flxdec, guchar * data, guchar * dest) + + while (packets--) { + /* skip count */ +- dest += *data++; ++ guchar skip = *data++; ++ dest += skip; + + /* RLE count */ + count = *data++; +@@ -364,12 +386,24 @@ flx_decode_delta_fli (GstFlxDec * flxdec, guchar * data, guchar * dest) + if (count > 0x7f) { + /* literal run */ + count = 0x100 - count; +- x = *data++; + ++ if (skip + count > flxdec->hdr.width) { ++ GST_ERROR_OBJECT (flxdec, "Invalid FLI packet detected. " ++ "line too long."); ++ return FALSE; ++ } ++ ++ x = *data++; + while (count--) + *dest++ = x; + + } else { ++ if (skip + count > flxdec->hdr.width) { ++ GST_ERROR_OBJECT (flxdec, "Invalid FLI packet detected. " ++ "line too long."); ++ return FALSE; ++ } ++ + /* replicate run */ + while (count--) + *dest++ = *data++; +@@ -378,21 +412,27 @@ flx_decode_delta_fli (GstFlxDec * flxdec, guchar * data, guchar * dest) + start_p += flxdec->hdr.width; + dest = start_p; + } ++ ++ return TRUE; + } + +-static void ++static gboolean + flx_decode_delta_flc (GstFlxDec * flxdec, guchar * data, guchar * dest) + { + gulong count, lines, start_l, opcode; + guchar *start_p; + +- g_return_if_fail (flxdec != NULL); +- g_return_if_fail (flxdec->delta_data != NULL); ++ g_return_val_if_fail (flxdec != NULL, FALSE); ++ g_return_val_if_fail (flxdec->delta_data != NULL, FALSE); + + /* use last frame for delta */ + memcpy (dest, flxdec->delta_data, flxdec->size); + + lines = (data[0] + (data[1] << 8)); ++ if (lines > flxdec->hdr.height) { ++ GST_ERROR_OBJECT (flxdec, "Invalid FLC packet detected. too many lines."); ++ return FALSE; ++ } + data += 2; + + start_p = dest; +@@ -405,9 +445,15 @@ flx_decode_delta_flc (GstFlxDec * flxdec, guchar * data, guchar * dest) + while ((opcode = (data[0] + (data[1] << 8))) & 0xc000) { + data += 2; + if ((opcode & 0xc000) == 0xc000) { +- /* skip count */ +- start_l += (0x10000 - opcode); +- dest += flxdec->hdr.width * (0x10000 - opcode); ++ /* line skip count */ ++ gulong skip = (0x10000 - opcode); ++ if (skip > flxdec->hdr.height) { ++ GST_ERROR_OBJECT (flxdec, "Invalid FLC packet detected. " ++ "skip line count too big."); ++ return FALSE; ++ } ++ start_l += skip; ++ dest += flxdec->hdr.width * skip; + } else { + /* last pixel */ + dest += flxdec->hdr.width; +@@ -419,7 +465,8 @@ flx_decode_delta_flc (GstFlxDec * flxdec, guchar * data, guchar * dest) + /* last opcode is the packet count */ + while (opcode--) { + /* skip count */ +- dest += *data++; ++ guchar skip = *data++; ++ dest += skip; + + /* RLE count */ + count = *data++; +@@ -427,12 +474,25 @@ flx_decode_delta_flc (GstFlxDec * flxdec, guchar * data, guchar * dest) + if (count > 0x7f) { + /* replicate word run */ + count = 0x100 - count; ++ ++ if (skip + count > flxdec->hdr.width) { ++ GST_ERROR_OBJECT (flxdec, "Invalid FLC packet detected. " ++ "line too long."); ++ return FALSE; ++ } ++ + while (count--) { + *dest++ = data[0]; + *dest++ = data[1]; + } + data += 2; + } else { ++ if (skip + count > flxdec->hdr.width) { ++ GST_ERROR_OBJECT (flxdec, "Invalid FLC packet detected. " ++ "line too long."); ++ return FALSE; ++ } ++ + /* literal word run */ + while (count--) { + *dest++ = *data++; +@@ -442,6 +502,8 @@ flx_decode_delta_flc (GstFlxDec * flxdec, guchar * data, guchar * dest) + } + lines--; + } ++ ++ return TRUE; + } + + static GstFlowReturn +@@ -571,9 +633,13 @@ gst_flxdec_chain (GstPad * pad, GstObject * parent, GstBuffer * buf) + out = gst_buffer_new_and_alloc (flxdec->size * 4); + + /* decode chunks */ +- flx_decode_chunks (flxdec, +- ((FlxFrameType *) chunk)->chunks, +- chunk + FlxFrameTypeSize, flxdec->frame_data); ++ if (!flx_decode_chunks (flxdec, ++ ((FlxFrameType *) chunk)->chunks, ++ chunk + FlxFrameTypeSize, flxdec->frame_data)) { ++ GST_ELEMENT_ERROR (flxdec, STREAM, DECODE, ++ ("%s", "Could not decode chunk"), NULL); ++ return GST_FLOW_ERROR; ++ } + + /* save copy of the current frame for possible delta. */ + memcpy (flxdec->delta_data, flxdec->frame_data, flxdec->size); +-- +2.10.2 + diff --git a/gnu/packages/patches/ldc-disable-tests.patch b/gnu/packages/patches/ldc-disable-tests.patch index 3f5e6c29a1..bdd6e5b76c 100644 --- a/gnu/packages/patches/ldc-disable-tests.patch +++ b/gnu/packages/patches/ldc-disable-tests.patch @@ -4,19 +4,9 @@ two others use networking. Not bad out of almost 700 tests! by Pjotr Prins <pjotr.guix@thebird.nl> -diff --git a/std/datetime.d b/std/datetime.d -index 8e4ed3b..6c15bc5 100644 ---- a/std/datetime.d -+++ b/std/datetime.d -@@ -28018,6 +28018,7 @@ public: - The default directory where the TZ Database files are. It's empty - for Windows, since Windows doesn't have them. - +/ -+ - enum defaultTZDatabaseDir = "/usr/share/zoneinfo/"; - } - else version(Windows) -@@ -28069,14 +28070,13 @@ assert(tz.dstName == "PDT"); +--- a/std/datetime.d.orig 2016-11-24 01:13:52.584495545 +0100 ++++ b/std/datetime.d 2016-11-24 01:17:09.655306728 +0100 +@@ -28081,22 +28081,24 @@ import std.range : retro; import std.format : format; @@ -25,9 +15,20 @@ index 8e4ed3b..6c15bc5 100644 enforce(tzDatabaseDir.exists(), new DateTimeException(format("Directory %s does not exist.", tzDatabaseDir))); enforce(tzDatabaseDir.isDir, new DateTimeException(format("%s is not a directory.", tzDatabaseDir))); -- immutable file = buildNormalizedPath(tzDatabaseDir, name); -+ auto filename = "./" ~ strip(name); // make sure the prefix is not stripped -+ immutable file = buildNormalizedPath(tzDatabaseDir, filename); + version(Android) + { ++ name = strip(name); + auto tzfileOffset = name in tzdataIndex(tzDatabaseDir); + enforce(tzfileOffset, new DateTimeException(format("The time zone %s is not listed.", name))); + string tzFilename = separate_index ? "zoneinfo.dat" : "tzdata"; + immutable file = buildNormalizedPath(tzDatabaseDir, tzFilename); + } + else +- immutable file = buildNormalizedPath(tzDatabaseDir, name); ++ { ++ auto filename = "./" ~ strip(name); // make sure the prefix is not stripped ++ immutable file = buildNormalizedPath(tzDatabaseDir, filename); ++ } - enforce(file.exists(), new DateTimeException(format("File %s does not exist.", file))); + enforce(file.exists(), new DateTimeException(format("File %s does not exist in %s.", file, tzDatabaseDir))); @@ -54,23 +55,6 @@ diff --git a/std/socket.d b/std/socket.d index b85d1c9..7fbf346 100644 --- a/std/socket.d +++ b/std/socket.d -@@ -517,6 +517,8 @@ class Protocol - - unittest - { -+ pragma(msg, "test disabled on GNU Guix"); -+/* - // getprotobyname,number are unimplemented on Android - softUnittest({ - Protocol proto = new Protocol; -@@ -530,6 +532,7 @@ unittest - assert(proto.name == "tcp"); - assert(proto.aliases.length == 1 && proto.aliases[0] == "TCP"); - }); -+*/ - } - - @@ -859,6 +862,8 @@ class InternetHost unittest diff --git a/gnu/packages/perl.scm b/gnu/packages/perl.scm index ab6120142d..e9f3dca15a 100644 --- a/gnu/packages/perl.scm +++ b/gnu/packages/perl.scm @@ -7,7 +7,7 @@ ;;; Copyright © 2016 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2016 Jochem Raat <jchmrt@riseup.net> ;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il> -;;; Coypright © 2016 ng0 <ng0@we.make.ritual.n0.is> +;;; Coypright © 2016 ng0 <ng0@libertad.pw> ;;; Copyright © 2016 Alex Sassmannshausen <alex@pompo.co> ;;; Copyright © 2016 Roel Janssen <roel@gnu.org> ;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com> @@ -2055,6 +2055,35 @@ each stack frame.") interface for the RFC 2104 HMAC mechanism.") (license (package-license perl)))) +(define-public perl-digest-md5 + (package + (name "perl-digest-md5") + (version "2.55") + (source + (origin + (method url-fetch) + (uri (string-append "mirror://cpan/authors/id/G/GA/GAAS/Digest-MD5-" + version ".tar.gz")) + (sha256 + (base32 + "0g0fklbrm2krswc1xhp4iwn1dhqq71fqh2p5wm8xj9a4s6i9ic83")))) + (build-system perl-build-system) + (arguments + `(#:phases + (modify-phases %standard-phases + (add-after 'build 'set-permissions + (lambda _ + ;; Make MD5.so read-write so it can be stripped. + (chmod "blib/arch/auto/Digest/MD5/MD5.so" #o755)))))) + (home-page "http://search.cpan.org/dist/Digest-MD5") + (synopsis "Perl interface to the MD-5 algorithm") + (description + "The @code{Digest::MD5} module allows you to use the MD5 Message Digest +algorithm from within Perl programs. The algorithm takes as +input a message of arbitrary length and produces as output a +128-bit \"fingerprint\" or \"message digest\" of the input.") + (license (package-license perl)))) + (define-public perl-digest-sha1 (package (name "perl-digest-sha1") diff --git a/gnu/packages/psyc.scm b/gnu/packages/psyc.scm deleted file mode 100644 index 03df188d1d..0000000000 --- a/gnu/packages/psyc.scm +++ /dev/null @@ -1,227 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016 ng0 <ngillmann@runbox.com> -;;; -;;; This file is part of GNU Guix. -;;; -;;; GNU Guix is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; GNU Guix is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. - -(define-module (gnu packages psyc) - #:use-module (guix download) - #:use-module (guix git-download) - #:use-module ((guix licenses) #:prefix license:) - #:use-module (guix packages) - #:use-module (guix build-system perl) - #:use-module (guix build-system gnu) - #:use-module (gnu packages) - #:use-module (gnu packages admin) - #:use-module (gnu packages autotools) - #:use-module (gnu packages bison) - #:use-module (gnu packages compression) - #:use-module (gnu packages gettext) - #:use-module (gnu packages linux) - #:use-module (gnu packages man) - #:use-module (gnu packages ncurses) - #:use-module (gnu packages perl) - #:use-module (gnu packages pcre) - #:use-module (gnu packages pkg-config) - #:use-module (gnu packages tls) - #:use-module (gnu packages web)) - -(define-public perl-net-psyc - (package - (name "perl-net-psyc") - (version "1.1") - (source - (origin - (method url-fetch) - (uri (string-append "http://perlpsyc.psyc.eu/" - "perlpsyc-" version ".zip")) - (file-name (string-append name "-" version ".zip")) - (sha256 - (base32 - "1lw6807qrbmvzbrjn1rna1dhir2k70xpcjvyjn45y35hav333a42")) - ;; psycmp3 currently depends on MP3::List and rxaudio (shareware), - ;; we can add it back when this is no longer the case. - (snippet '(delete-file "contrib/psycmp3")))) - (build-system perl-build-system) - (inputs - `(("perl-curses" ,perl-curses) - ("perl-io-socket-ssl" ,perl-io-socket-ssl))) - (arguments - `(#:phases - (modify-phases %standard-phases - (delete 'configure) ; No configure script - ;; There is a Makefile, but it does not install everything - ;; (leaves out psycion) and says - ;; "# Just to give you a rough idea". XXX: Fix it upstream. - (replace 'build - (lambda _ - (zero? (system* "make" "manuals")))) - (replace 'install - (lambda* (#:key outputs #:allow-other-keys) - (let* ((out (assoc-ref outputs "out")) - (doc (string-append out "/share/doc/perl-net-psyc")) - (man1 (string-append out "/share/man/man1")) - (man3 (string-append out "/share/man/man3")) - (bin (string-append out "/bin")) - (libpsyc (string-append out "/lib/psyc/ion")) - (libperl (string-append out "/lib/perl5/site_perl/" - ,(package-version perl)))) - - (copy-recursively "lib/perl5" libperl) - (copy-recursively "lib/psycion" libpsyc) - (copy-recursively "bin" bin) - (install-file "cgi/psycpager" (string-append doc "/cgi")) - (copy-recursively "contrib" (string-append doc "/contrib")) - (copy-recursively "hooks" (string-append doc "/hooks")) - (copy-recursively "sdj" (string-append doc "/sdj")) - (install-file "README.txt" doc) - (install-file "TODO.txt" doc) - (copy-recursively "share/man/man1" man1) - (copy-recursively "share/man/man3" man3) - #t))) - (add-after 'install 'wrap-programs - (lambda* (#:key outputs #:allow-other-keys) - ;; Make sure all executables in "bin" find the Perl modules - ;; provided by this package at runtime. - (let* ((out (assoc-ref outputs "out")) - (bin (string-append out "/bin/")) - (path (getenv "PERL5LIB"))) - (for-each (lambda (file) - (wrap-program file - `("PERL5LIB" ":" prefix (,path)))) - (find-files bin "\\.*$")) - #t)))))) - (description - "@code{Net::PSYC} with support for TCP, UDP, Event.pm, @code{IO::Select} and -Gtk2 event loops. This package includes 12 applications and additional scripts: -psycion (a @uref{http://about.psyc.eu,PSYC} chat client), remotor (a control console -for @uref{https://torproject.org,tor} router) and many more.") - (synopsis "Perl implementation of PSYC protocol") - (home-page "http://perlpsyc.psyc.eu/") - (license (list license:gpl2 - (package-license perl) - ;; contrib/irssi-psyc.pl: - license:public-domain - ;; bin/psycplay states AGPL with no version: - license:agpl3+)))) - -(define-public libpsyc - (package - (name "libpsyc") - (version "20160913") - (source (origin - (method url-fetch) - (uri (string-append "http://www.psyced.org/files/" - name "-" version ".tar.xz")) - (sha256 - (base32 - "14q89fxap05ajkfn20rnhc6b1h4i3i2adyr7y6hs5zqwb2lcmc1p")))) - (build-system gnu-build-system) - (native-inputs - `(("perl" ,perl) - ("netcat" ,netcat) - ("procps" ,procps))) - (arguments - `(#:make-flags - (list "CC=gcc" - (string-append "PREFIX=" (assoc-ref %outputs "out"))) - #:phases - (modify-phases %standard-phases - ;; The rust bindings are the only ones in use, the lpc bindings - ;; are in psyclpc. The other bindings are not used by anything, - ;; the chances are high that the bindings do not even work, - ;; therefore we do not include them. - ;; TODO: Get a cargo build system in Guix. - (delete 'configure)))) ; no configure script - (home-page "http://about.psyc.eu/libpsyc") - (description - "@code{libpsyc} is a PSYC library in C which implements -core aspects of PSYC, useful for all kinds of clients and servers -including psyced.") - (synopsis "PSYC library in C") - (license license:agpl3+))) - -;; This commit removes the historic bundled pcre, not released as a tarball so far. -(define-public psyclpc - (let* ((commit "8bd51f2a4847860ba8b82dc79348ab37d516011e") - (revision "1")) - (package - (name "psyclpc") - (version (string-append "20160821-" revision "." (string-take commit 7))) - (source (origin - (method git-fetch) - (uri (git-reference - (url "git://git.psyced.org/git/psyclpc") - (commit commit))) - (file-name (string-append name "-" version "-checkout")) - (sha256 - (base32 - "10w4kx9ygcv1lcmd7j4knvjiy8dac1y3hjfv3lhp67jpv6w3iagz")))) - (build-system gnu-build-system) - (arguments - `(#:tests? #f ; There are no tests/checks. - #:configure-flags - ;; If you have questions about this part, look at - ;; "src/settings/psyced" and the ebuild. - (list - "--enable-use-tls=yes" - "--enable-use-mccp" ; Mud Client Compression Protocol, leave this enabled. - (string-append "--prefix=" - (assoc-ref %outputs "out")) - ;; src/Makefile: Set MUD_LIB to the directory which contains - ;; the mud data. defaults to MUD_LIB = @libdir@ - (string-append "--libdir=" - (assoc-ref %outputs "out") - "/opt/psyced/world") - (string-append "--bindir=" - (assoc-ref %outputs "out") - "/opt/psyced/bin") - ;; src/Makefile: Set ERQ_DIR to directory which contains the - ;; stuff which ERQ can execute (hopefully) savely. Was formerly - ;; defined in config.h. defaults to ERQ_DIR= @libexecdir@ - (string-append "--libexecdir=" - (assoc-ref %outputs "out") - "/opt/psyced/run")) - #:phases - (modify-phases %standard-phases - (add-before 'configure 'chdir-to-src - ;; We need to pass this as env variables - ;; and manually change the directory. - (lambda _ - (chdir "src") - (setenv "CONFIG_SHELL" (which "sh")) - (setenv "SHELL" (which "sh")) - #t))) - #:make-flags (list "install-all"))) - (inputs - `(("zlib" ,zlib) - ("openssl" ,openssl) - ("pcre" ,pcre))) - (native-inputs - `(("pkg-config" ,pkg-config) - ("bison" ,bison) - ("gettext" ,gettext-minimal) - ("help2man" ,help2man) - ("autoconf" ,autoconf) - ("automake" ,automake))) - (home-page "http://lpc.psyc.eu/") - (synopsis "psycLPC is a multi-user network server programming language") - (description - "LPC is a bytecode language, invented to specifically implement -multi user virtual environments on the internet. This technology is used for -MUDs and also the psyced implementation of the Protocol for SYnchronous -Conferencing (PSYC). psycLPC is a fork of LDMud with some new features and -many bug fixes.") - (license license:gpl2)))) diff --git a/gnu/packages/python.scm b/gnu/packages/python.scm index 123b30800d..497da52264 100644 --- a/gnu/packages/python.scm +++ b/gnu/packages/python.scm @@ -31,6 +31,7 @@ ;;; Copyright © 2016 Dylan Jeffers <sapientech@sapientech@openmailbox.org> ;;; Copyright © 2016 Alex Vong <alexvong1995@gmail.com> ;;; Copyright © 2016 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2016 Julien Lepiller <julien@lepiller.eu> ;;; ;;; This file is part of GNU Guix. ;;; @@ -453,14 +454,14 @@ pidof, tty, taskset, pmap.") (define-public python-passlib (package (name "python-passlib") - (version "1.6.5") + (version "1.7.0") (source (origin (method url-fetch) (uri (pypi-uri "passlib" version)) (sha256 (base32 - "1z27wdxs5rj5xhhqfzvzn3yg682irkxw6dcs5jj7mcf97psk8gd8")))) + "1vdbqsa1a31s98fxkinl052q8nnpvbxnb83qanxfpi2p6c2zdr0b")))) (build-system python-build-system) (native-inputs `(("python-nose" ,python-nose) @@ -1180,14 +1181,14 @@ after Andy Lester’s Perl module WWW::Mechanize.") (define-public python-simplejson (package (name "python-simplejson") - (version "3.8.2") + (version "3.10.0") (source (origin (method url-fetch) (uri (pypi-uri "simplejson" version)) (sha256 (base32 - "0zylrnax8b6r0ndgni4w9c599fi6wm9vx5g6k3ddqfj3932kk16m")))) + "1qhwsykjlb85igb4cfl6v6gkprzbbg8gyqdd7zscc8w3x0ifcfwm")))) (build-system python-build-system) (home-page "http://simplejson.readthedocs.org/en/latest/") (synopsis @@ -1426,6 +1427,31 @@ backported for previous versions of Python from 2.4 to 3.3.") syntax.") (license license:x11))) +(define-public python-polib + (package + (name "python-polib") + (version "1.0.8") + (source (origin + (method url-fetch) + (uri (pypi-uri "polib" version)) + (sha256 + (base32 + "1pq2hbm3m2q0cjdszk8mc4qa1vl3wcblh5nfyirlfnzb2pcy7zss")))) + (build-system python-build-system) + (home-page "https://bitbucket.org/izi/polib/wiki/Home") + (synopsis "Manipulate, create and modify gettext files") + (description "Polib can manipulate any gettext format (po, pot and mo) +files. It can be used to create po files from scratch or to modify +existing ones.") + (license license:expat))) + +(define-public python2-polib + (let ((base (package-with-python2 (strip-python2-variant python-polib)))) + (package + (inherit base) + (arguments `(,@(package-arguments base) + ;; Tests don't work with python2. + #:tests? #f))))) (define-public scons (package @@ -6697,14 +6723,14 @@ message digests and key derivation functions.") (define-public python-pyopenssl (package (name "python-pyopenssl") - (version "16.1.0") + (version "16.2.0") (source (origin (method url-fetch) (uri (pypi-uri "pyOpenSSL" version)) (sha256 (base32 - "0prm06zz7hl6bk5s2lqzw25lq6smayfv2fgiliw2rbqxlyiavxw8")))) + "0vji4yrfshs15xpczbhzhasnjrwcarsqg87n98ixnyafnyxs6ybp")))) (build-system python-build-system) (propagated-inputs `(("python-cryptography" ,python-cryptography) @@ -9532,18 +9558,20 @@ useful for solving the Assignment Problem.") (define-public python-flask (package (name "python-flask") - (version "0.10.1") + (version "0.11.1") (source (origin (method url-fetch) (uri (pypi-uri "Flask" version)) (sha256 (base32 - "0wrkavjdjndknhp8ya8j850jq7a1cli4g5a93mg8nh1xz2gq50sc")))) + "03kbfll4sj3v5z7r31c7bhfpi11r1np076d4p1k2kg4yzcmkywdl")))) (build-system python-build-system) (propagated-inputs `(("python-itsdangerous" ,python-itsdangerous) ("python-jinja2" ,python-jinja2) ("python-werkzeug" ,python-werkzeug))) + (native-inputs + `(("python-click" ,python-click))) (home-page "https://github.com/mitsuhiko/flask/") (synopsis "Microframework based on Werkzeug, Jinja2 and good intentions") (description "Flask is a micro web framework based on the Werkzeug toolkit diff --git a/gnu/packages/qemu.scm b/gnu/packages/qemu.scm index 3c48b7a278..e429c04244 100644 --- a/gnu/packages/qemu.scm +++ b/gnu/packages/qemu.scm @@ -119,7 +119,7 @@ (let ((infodir (string-append out "/share/info"))) (for-each (lambda (info) (install-file info infodir)) - (find-files "." "\\.info$")) + (find-files "." "\\.info")) #t)))))) (add-before 'check 'make-gtester-verbose (lambda _ diff --git a/gnu/packages/ssh.scm b/gnu/packages/ssh.scm index 5fdeeb74a4..ea5ec811d1 100644 --- a/gnu/packages/ssh.scm +++ b/gnu/packages/ssh.scm @@ -204,24 +204,24 @@ Additionally, various channel-specific options can be negotiated.") (define-public guile-ssh (package (name "guile-ssh") - (version "0.10.1") + (version "0.10.2") + (home-page "https://github.com/artyom-poptsov/guile-ssh") (source (origin ;; ftp://memory-heap.org/software/guile-ssh/guile-ssh-VERSION.tar.gz ;; exists, but the server appears to be too slow and unreliable. - (method git-fetch) - (uri (git-reference - (url "https://github.com/artyom-poptsov/libguile-ssh.git") - (commit (string-append "v" version)))) - (file-name (string-append name "-" version "-checkout")) + ;; Also, using this URL allows the GitHub updater to work. + (method url-fetch) + (uri (string-append home-page "/archive/v" + version ".tar.gz")) + (file-name (string-append name "-" version ".tar.gz")) (sha256 (base32 - "0ky77kr7rnkhbq938bir61mlr8b86lfjcjjb1bxx1y1fhimsiz72")))) + "0pkiq3fm15pr4w1r420rrwwfmi4jz492r6l6vzjk6v73xlyfyfl3")))) (build-system gnu-build-system) (arguments '(#:phases (modify-phases %standard-phases (add-after 'unpack 'autoreconf (lambda* (#:key inputs #:allow-other-keys) - (chmod "doc/version.texi" #o777) ;make it writable (zero? (system* "autoreconf" "-vfi")))) (add-before 'build 'fix-libguile-ssh-file-name (lambda* (#:key outputs #:allow-other-keys) @@ -255,7 +255,6 @@ Additionally, various channel-specific options can be negotiated.") "Guile-SSH is a library that provides access to the SSH protocol for programs written in GNU Guile interpreter. It is a wrapper to the underlying libssh library.") - (home-page "https://github.com/artyom-poptsov/libguile-ssh") (license license:gpl3+))) (define-public corkscrew diff --git a/gnu/packages/telephony.scm b/gnu/packages/telephony.scm index 3d5e58ec2d..6597d26096 100644 --- a/gnu/packages/telephony.scm +++ b/gnu/packages/telephony.scm @@ -5,6 +5,7 @@ ;;; Copyright © 2015 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2016 Lukas Gradl <lgradl@openmailbox.org> ;;; Copyright © 2016 Francesco Frassinelli <fraph24@gmail.com> +;;; Copyright © 2016 ng0 <ng0@libertad.pw> ;;; ;;; This file is part of GNU Guix. ;;; @@ -24,13 +25,20 @@ (define-module (gnu packages telephony) #:use-module (gnu packages) #:use-module (gnu packages autotools) + #:use-module (gnu packages avahi) + #:use-module (gnu packages boost) + #:use-module (gnu packages protobuf) #:use-module (gnu packages gnupg) #:use-module (gnu packages linux) #:use-module (gnu packages multiprecision) #:use-module (gnu packages ncurses) #:use-module (gnu packages pkg-config) + #:use-module (gnu packages pulseaudio) + #:use-module (gnu packages qt) + #:use-module (gnu packages speech) #:use-module (gnu packages tls) #:use-module (gnu packages xiph) + #:use-module (gnu packages xorg) #:use-module ((guix licenses) #:prefix license:) #:use-module (guix packages) #:use-module (guix download) @@ -287,3 +295,107 @@ lists. All you need to join an existing conference is the host name or IP address of one of the participants.") (home-page "http://holdenc.altervista.org/seren/") (license license:gpl3+))) + +(define-public mumble + (package + (name "mumble") + (version "1.2.17") + (source (origin + (method url-fetch) + (uri (string-append "https://mumble.info/snapshot/" + name "-" version ".tar.gz")) + (sha256 + (base32 + "176br3b0pv5sz3zvgzsz9rxr3n79irlm902h7n1wh4f6vbph2dhw")) + (modules '((guix build utils))) + (snippet + `(begin + ;; Remove bundled software. + (for-each delete-file-recursively '("3rdparty" + "speex" + "speexbuild" + "opus-build" + "opus-src" + "sbcelt-helper-build" + "sbcelt-lib-build" + "sbcelt-src")) + ;; TODO: Celt is still bundled. It has been merged into Opus + ;; and will be removed after 1.3.0. + ;; https://github.com/mumble-voip/mumble/issues/1999 + #t)))) + (build-system gnu-build-system) + (arguments + `(#:tests? #f ; no "check" target + #:phases + (modify-phases %standard-phases + (replace 'configure + (lambda* (#:key outputs #:allow-other-keys) + (zero? (system* "qmake" "main.pro" "-recursive" + (string-append "CONFIG+=" + (string-join + (list "no-update" + "no-server" + "no-embed-qt-translations" + "no-bundled-speex" + "pch" + "no-bundled-opus" + "no-celt" + "no-alsa" + "no-oss" + "no-portaudio" + "speechd" + "no-g15" + "no-bonjour" + "release"))) + (string-append "DEFINES+=" + "PLUGIN_PATH=" + (assoc-ref outputs "out") + "/lib/mumble"))))) + (add-before 'configure 'fix-libspeechd-include + (lambda _ + (substitute* "src/mumble/TextToSpeech_unix.cpp" + (("libspeechd.h") "speech-dispatcher/libspeechd.h")))) + (replace 'install ; install phase does not exist + (lambda* (#:key inputs outputs #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (bin (string-append out "/bin")) + (services (string-append out "/share/services")) + (applications (string-append out "/share/applications")) + (icons (string-append out "/share/icons/hicolor/scalable/apps")) + (man (string-append out "/share/man/man1")) + (lib (string-append out "/lib/mumble"))) + (install-file "release/mumble" bin) + (install-file "scripts/mumble-overlay" bin) + (install-file "scripts/mumble.protocol" services) + (install-file "scripts/mumble.desktop" applications) + (install-file "icons/mumble.svg" icons) + (install-file "man/mumble-overlay.1" man) + (install-file "man/mumble.1" man) + (for-each (lambda (file) (install-file file lib)) + (find-files "." "\\.so\\.")) + (for-each (lambda (file) (install-file file lib)) + (find-files "release/plugins" "\\.so$")))))))) + (inputs + `(("avahi" ,avahi) + ("protobuf" ,protobuf) + ("openssl" ,openssl) + ("libsndfile" ,libsndfile) + ("boost" ,boost) + ("opus" ,opus) + ("speex" ,speex) + ("speech-dispatcher" ,speech-dispatcher) + ("libx11" ,libx11) + ("libxi" ,libxi) + ("qt-4" ,qt-4) + ("alsa-lib" ,alsa-lib) + ("pulseaudio" ,pulseaudio))) + (native-inputs + `(("pkg-config" ,pkg-config))) + (synopsis "Low-latency, high quality voice chat software") + (description + "Mumble is an low-latency, high quality voice chat +software primarily intended for use while gaming.") + (home-page "https://wiki.mumble.info/wiki/Main_Page") + (license (list license:bsd-3 + ;; The bundled celt is bsd-2. Remove after 1.3.0. + license:bsd-2)))) diff --git a/gnu/packages/upnp.scm b/gnu/packages/upnp.scm index c46e905c42..f680a52881 100644 --- a/gnu/packages/upnp.scm +++ b/gnu/packages/upnp.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in> +;;; Copyright © 2016 Tobias Geerinckx-Rice <me@tobias.gr> ;;; ;;; This file is part of GNU Guix. ;;; @@ -27,7 +28,7 @@ (define-public miniupnpc (package (name "miniupnpc") - (version "1.9") + (version "2.0") (source (origin (method url-fetch) @@ -35,7 +36,7 @@ "http://miniupnp.tuxfamily.org/files/miniupnpc-" version ".tar.gz")) (sha256 - (base32 "0r24jdqcyf839n30ppimdna0hvybscyziaad7ng99fw0x19y88r9")))) + (base32 "0fzrc6fs8vzb2yvk01bd3q5jkarysl7gjlyaqncy3yvfk2wcwd6l")))) (build-system gnu-build-system) (native-inputs `(("python" ,python-2))) @@ -54,14 +55,22 @@ (string-append "LDFLAGS=-Wl,-rpath=" (assoc-ref %outputs "out") "/lib")) #:phases - (alist-delete 'configure %standard-phases))) + (modify-phases %standard-phases + (delete 'configure) + (add-before 'install 'qualify-paths + (lambda* (#:key outputs #:allow-other-keys) + (substitute* "external-ip.sh" + (("upnpc") + (string-append (assoc-ref outputs "out") "/bin/upnpc")))))))) (home-page "http://miniupnp.free.fr/") - (synopsis "Library implementing the client side UPnP protocol") + (synopsis "UPnP protocol client library") (description - "MiniUPnPc is a library is useful whenever an application needs to listen -for incoming connections but is run behind a UPnP enabled router or firewall. -Examples for such applications include: P2P applications, FTP clients for -active mode, IRC (for DCC) or IM applications, network games, any server -software.") + "The MiniUPnPc client library facilitates access to the services provided +by any Universal Plug and Play (UPnP) Internet Gateway Device (IGD) present on +the network. In UPnP terminology, MiniUPnPc is a UPnP Control Point. It is +useful whenever an application needs to listen for incoming connections while +running behind a UPnP-enabled router or firewall. Such applications include +peer-to-peer applications, active-mode FTP clients, DCC file transfers over +IRC, instant messaging, network games, and most server software.") (license (x11-style "file://LICENSE" "See 'LICENSE' file in the distribution")))) diff --git a/gnu/packages/video.scm b/gnu/packages/video.scm index 4eab99b5aa..3b93f27426 100644 --- a/gnu/packages/video.scm +++ b/gnu/packages/video.scm @@ -441,14 +441,14 @@ standards (MPEG-2, MPEG-4 ASP/H.263, MPEG-4 AVC/H.264, and VC-1/VMW3).") (define-public ffmpeg (package (name "ffmpeg") - (version "3.2") + (version "3.2.1") (source (origin (method url-fetch) (uri (string-append "https://ffmpeg.org/releases/ffmpeg-" version ".tar.xz")) (sha256 (base32 - "1nnmd3h9pr2zic08isjcm1cmvcyd0aimpayb9r4qy45bihdhrxw8")))) + "1pxsy9s9n2nvz970rid3j3b45w6s7ziwnrbc16rny7k0bpd97kqy")))) (build-system gnu-build-system) (inputs `(("fontconfig" ,fontconfig) diff --git a/gnu/packages/vim.scm b/gnu/packages/vim.scm index 678f895917..83c21249b4 100644 --- a/gnu/packages/vim.scm +++ b/gnu/packages/vim.scm @@ -49,7 +49,7 @@ (define-public vim (package (name "vim") - (version "8.0.0095") + (version "8.0.0101") (source (origin (method url-fetch) (uri (string-append "https://github.com/vim/vim/archive/v" @@ -57,7 +57,7 @@ (file-name (string-append name "-" version ".tar.gz")) (sha256 (base32 - "1whib2zzqdpgfhpr7ymqxj3das6iyiapvx0izw4147mkg9yanmp7")))) + "0kzk1p5vnqr8j5jwb3p745zx3dki5jwlsp7rh6nli0ci2w6vg3r8")))) (build-system gnu-build-system) (arguments `(#:test-target "test" diff --git a/gnu/packages/web.scm b/gnu/packages/web.scm index 063a8a9a15..753a81625c 100644 --- a/gnu/packages/web.scm +++ b/gnu/packages/web.scm @@ -123,14 +123,14 @@ and its related documentation.") (define-public nginx (package (name "nginx") - (version "1.11.4") + (version "1.11.6") (source (origin (method url-fetch) (uri (string-append "https://nginx.org/download/nginx-" version ".tar.gz")) (sha256 (base32 - "0fvb09ycxz3xnyynav6ybj6miwh9kv8jcb2vzrmvqhzn8cgiq8h6")))) + "1gc5phrzm2hbpvryaya6rlvasa00vjips4hv5q1rqbcfa6xsnlri")))) (build-system gnu-build-system) (inputs `(("pcre" ,pcre) ("openssl" ,openssl) @@ -150,7 +150,6 @@ and its related documentation.") (list (string-append "--prefix=" (assoc-ref outputs "out")) "--with-http_ssl_module" "--with-pcre-jit" - "--with-ipv6" "--with-debug" ;; Even when not cross-building, we pass the ;; --crossbuild option to avoid customizing for the diff --git a/gnu/packages/wxwidgets.scm b/gnu/packages/wxwidgets.scm index 31da2a9eed..b72567f259 100644 --- a/gnu/packages/wxwidgets.scm +++ b/gnu/packages/wxwidgets.scm @@ -1,6 +1,8 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com> ;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2016 Theodoros Foradis <theodoros.for@openmailbox.org> +;;; Copyright © 2016 Danny Milosavljevic <dannym@scratchpost.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,6 +24,7 @@ #:use-module (guix download) #:use-module ((guix licenses) #:prefix l:) #:use-module (guix build-system glib-or-gtk) + #:use-module (guix build-system python) #:use-module (guix build utils) #:use-module (gnu packages) #:use-module (gnu packages compression) @@ -31,6 +34,7 @@ #:use-module (gnu packages gtk) #:use-module (gnu packages image) #:use-module (gnu packages pkg-config) + #:use-module (gnu packages python) #:use-module (gnu packages sdl) #:use-module (gnu packages webkit) #:use-module (gnu packages xorg)) @@ -109,3 +113,80 @@ and many other languages.") (assoc-ref %outputs "out") "/lib")) ;; No 'check' target. #:tests? #f)))) + +(define-public wxwidgets-gtk2 + (package (inherit wxwidgets) + (inputs `(("gtk+" ,gtk+-2) + ,@(alist-delete + "gtk+" + (package-inputs wxwidgets)))) + (name "wxwidgets-gtk2"))) + +(define-public python2-wxpython + (package + (name "python2-wxpython") + (version "3.0.2.0") + (source + (origin + (method url-fetch) + (uri (string-append "mirror://sourceforge/wxpython/wxPython/" + version "/wxPython-src-" version ".tar.bz2")) + (sha256 + (base32 + "0qfzx3sqx4mwxv99sfybhsij4b5pc03ricl73h4vhkzazgjjjhfm")) + (modules '((guix build utils))) + (snippet + '(begin + (lambda (folder) + (delete-file-recursively (string-append "src/" folder)) + '("expat" "jpeg" "png" "tiff" "zlib" "msw" "osx" "msdos")) + (substitute* '("wxPython/setup.py") + ;; setup.py tries to keep its own license the same as wxwidget's + ;; license (which it expects under $WXWIN/docs). + (("'preamble.txt', 'licence.txt', 'licendoc.txt', 'lgpl.txt'") + "")))))) + (build-system python-build-system) + (arguments + `(#:python ,python-2 + #:tests? #f ; tests fail + #:configure-flags (list "WXPORT=gtk2" + "UNICODE=1") + #:phases + (modify-phases %standard-phases + (add-before 'build 'chdir + (lambda _ + (chdir "wxPython") + #t)) + (add-after 'chdir 'set-wx-out-dir + (lambda* (#:key outputs #:allow-other-keys) + ;; By default, install phase tries to copy the wxPython headers in + ;; gnu/store/...-wxwidgets-3.0.2 , which it can't, so they are + ;; redirected to the output directory by setting WXPREFIX. + (substitute* "config.py" + (("= getWxConfigValue\\('--prefix'\\)") + (string-append "= '" (assoc-ref outputs "out") "'"))) + (substitute* "wx/build/config.py" + (("= getWxConfigValue\\('--prefix'\\)") + (string-append "= '" (assoc-ref outputs "out") "'"))) + #t)) + (add-after 'set-wx-out-dir 'setenv + (lambda* (#:key inputs outputs #:allow-other-keys) + (setenv "WXWIN" (assoc-ref inputs "wxwidgets")) + (use-modules (ice-9 popen) (ice-9 rdelim)) + (let ((port (open-pipe* OPEN_READ + (string-append (assoc-ref inputs "wxwidgets") + "/bin/wx-config") "--cppflags"))) + (setenv "CPPFLAGS" (read-string port)) + (close-pipe port)) + #t))))) + (native-inputs + `(("mesa" ,mesa) ; for glcanvas + ("pkg-config" ,pkg-config) + ("python2-setuptools" ,python2-setuptools))) + (inputs + `(("gtk+" ,gtk+-2) ; for wxPython/src/helpers.cpp + ("wxwidgets" ,wxwidgets-gtk2))) + (synopsis "Python 2 Bindings for wxWidgets") + (description "@code{wxpython} provides Python 2 bindings for wxWidgets.") + (home-page "http://wxpython.org/") + (license (package-license wxwidgets)))) diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm new file mode 100644 index 0000000000..9f28aabc96 --- /dev/null +++ b/gnu/services/configuration.scm @@ -0,0 +1,205 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 Andy Wingo <wingo@igalia.com> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (gnu services configuration) + #:use-module (guix packages) + #:use-module (guix records) + #:use-module (guix gexp) + #:autoload (texinfo) (texi-fragment->stexi) + #:autoload (texinfo serialize) (stexi->texi) + #:use-module (ice-9 match) + #:use-module ((srfi srfi-1) #:select (append-map)) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:export (configuration-field + configuration-field-name + configuration-missing-field + configuration-field-error + serialize-configuration + define-configuration + validate-configuration + generate-documentation + serialize-field + serialize-string + serialize-name + serialize-space-separated-string-list + space-separated-string-list? + serialize-file-name + file-name? + serialize-boolean + serialize-package)) + +;;; Commentary: +;;; +;;; Syntax for creating Scheme bindings to complex configuration files. +;;; +;;; Code: + +(define-condition-type &configuration-error &error + configuration-error?) + +(define (configuration-error message) + (raise (condition (&message (message message)) + (&configuration-error)))) +(define (configuration-field-error field val) + (configuration-error + (format #f "Invalid value for field ~a: ~s" field val))) +(define (configuration-missing-field kind field) + (configuration-error + (format #f "~a configuration missing required field ~a" kind field))) + +(define-record-type* <configuration-field> + configuration-field make-configuration-field configuration-field? + (name configuration-field-name) + (type configuration-field-type) + (getter configuration-field-getter) + (predicate configuration-field-predicate) + (serializer configuration-field-serializer) + (default-value-thunk configuration-field-default-value-thunk) + (documentation configuration-field-documentation)) + +(define (serialize-configuration config fields) + (for-each (lambda (field) + ((configuration-field-serializer field) + (configuration-field-name field) + ((configuration-field-getter field) config))) + fields)) + +(define (validate-configuration config fields) + (for-each (lambda (field) + (let ((val ((configuration-field-getter field) config))) + (unless ((configuration-field-predicate field) val) + (configuration-field-error + (configuration-field-name field) val)))) + fields)) + +(define-syntax define-configuration + (lambda (stx) + (define (id ctx part . parts) + (let ((part (syntax->datum part))) + (datum->syntax + ctx + (match parts + (() part) + (parts (symbol-append part + (syntax->datum (apply id ctx parts)))))))) + (syntax-case stx () + ((_ stem (field (field-type def) doc) ...) + (with-syntax (((field-getter ...) + (map (lambda (field) + (id #'stem #'stem #'- field)) + #'(field ...))) + ((field-predicate ...) + (map (lambda (type) + (id #'stem type #'?)) + #'(field-type ...))) + ((field-serializer ...) + (map (lambda (type) + (id #'stem #'serialize- type)) + #'(field-type ...)))) + #`(begin + (define-record-type* #,(id #'stem #'< #'stem #'>) + #,(id #'stem #'% #'stem) + #,(id #'stem #'make- #'stem) + #,(id #'stem #'stem #'?) + (field field-getter (default def)) + ...) + (define #,(id #'stem #'stem #'-fields) + (list (configuration-field + (name 'field) + (type 'field-type) + (getter field-getter) + (predicate field-predicate) + (serializer field-serializer) + (default-value-thunk (lambda () def)) + (documentation doc)) + ...)) + (define-syntax-rule (stem arg (... ...)) + (let ((conf (#,(id #'stem #'% #'stem) arg (... ...)))) + (validate-configuration conf + #,(id #'stem #'stem #'-fields)) + conf)))))))) + +(define (uglify-field-name field-name) + (let ((str (symbol->string field-name))) + (string-concatenate + (map string-titlecase + (string-split (if (string-suffix? "?" str) + (substring str 0 (1- (string-length str))) + str) + #\-))))) + +(define (serialize-field field-name val) + (format #t "~a ~a\n" (uglify-field-name field-name) val)) + +(define (serialize-package field-name val) + #f) + +(define (serialize-string field-name val) + (serialize-field field-name val)) + +(define (space-separated-string-list? val) + (and (list? val) + (and-map (lambda (x) + (and (string? x) (not (string-index x #\space)))) + val))) +(define (serialize-space-separated-string-list field-name val) + (serialize-field field-name (string-join val " "))) + +(define (file-name? val) + (and (string? val) + (string-prefix? "/" val))) +(define (serialize-file-name field-name val) + (serialize-string field-name val)) + +(define (serialize-boolean field-name val) + (serialize-string field-name (if val "yes" "no"))) + +;; A little helper to make it easier to document all those fields. +(define (generate-documentation documentation documentation-name) + (define (str x) (object->string x)) + (define (generate configuration-name) + (match (assq-ref documentation configuration-name) + ((fields . sub-documentation) + `((para "Available " (code ,(str configuration-name)) " fields are:") + ,@(map + (lambda (f) + (let ((field-name (configuration-field-name f)) + (field-type (configuration-field-type f)) + (field-docs (cdr (texi-fragment->stexi + (configuration-field-documentation f)))) + (default (catch #t + (configuration-field-default-value-thunk f) + (lambda _ '%invalid)))) + (define (show-default? val) + (or (string? default) (number? default) (boolean? default) + (and (symbol? val) (not (eq? val '%invalid))) + (and (list? val) (and-map show-default? val)))) + `(deftypevr (% (category + (code ,(str configuration-name)) " parameter") + (data-type ,(str field-type)) + (name ,(str field-name))) + ,@field-docs + ,@(if (show-default? default) + `((para "Defaults to " (samp ,(str default)) ".")) + '()) + ,@(append-map + generate + (or (assq-ref sub-documentation field-name) '()))))) + fields))))) + (stexi->texi `(*fragment* . ,(generate documentation-name)))) diff --git a/gnu/services/cups.scm b/gnu/services/cups.scm index 7542ee26c0..391046a75f 100644 --- a/gnu/services/cups.scm +++ b/gnu/services/cups.scm @@ -19,6 +19,7 @@ (define-module (gnu services cups) #:use-module (gnu services) #:use-module (gnu services shepherd) + #:use-module (gnu services configuration) #:use-module (gnu system shadow) #:use-module (gnu packages admin) #:use-module (gnu packages cups) @@ -26,16 +27,9 @@ #:use-module (guix packages) #:use-module (guix records) #:use-module (guix gexp) - #:use-module (texinfo) - #:use-module (texinfo serialize) #:use-module (ice-9 match) #:use-module ((srfi srfi-1) #:select (append-map)) - #:use-module (srfi srfi-34) - #:use-module (srfi srfi-35) - #:export (&cups-configuation-error - cups-configuration-error? - - cups-service-type + #:export (cups-service-type cups-configuration opaque-cups-configuration @@ -51,91 +45,6 @@ ;;; ;;; Code: -(define-condition-type &cups-configuration-error &error - cups-configuration-error?) - -(define (cups-error message) - (raise (condition (&message (message message)) - (&cups-configuration-error)))) -(define (cups-configuration-field-error field val) - (cups-error - (format #f "Invalid value for field ~a: ~s" field val))) -(define (cups-configuration-missing-field kind field) - (cups-error - (format #f "~a configuration missing required field ~a" kind field))) - -(define-record-type* <configuration-field> - configuration-field make-configuration-field configuration-field? - (name configuration-field-name) - (type configuration-field-type) - (getter configuration-field-getter) - (predicate configuration-field-predicate) - (serializer configuration-field-serializer) - (default-value-thunk configuration-field-default-value-thunk) - (documentation configuration-field-documentation)) - -(define (serialize-configuration config fields) - (for-each (lambda (field) - ((configuration-field-serializer field) - (configuration-field-name field) - ((configuration-field-getter field) config))) - fields)) - -(define (validate-configuration config fields) - (for-each (lambda (field) - (let ((val ((configuration-field-getter field) config))) - (unless ((configuration-field-predicate field) val) - (cups-configuration-field-error - (configuration-field-name field) val)))) - fields)) - -(define-syntax define-configuration - (lambda (stx) - (define (id ctx part . parts) - (let ((part (syntax->datum part))) - (datum->syntax - ctx - (match parts - (() part) - (parts (symbol-append part - (syntax->datum (apply id ctx parts)))))))) - (syntax-case stx () - ((_ stem (field (field-type def) doc) ...) - (with-syntax (((field-getter ...) - (map (lambda (field) - (id #'stem #'stem #'- field)) - #'(field ...))) - ((field-predicate ...) - (map (lambda (type) - (id #'stem type #'?)) - #'(field-type ...))) - ((field-serializer ...) - (map (lambda (type) - (id #'stem #'serialize- type)) - #'(field-type ...)))) - #`(begin - (define-record-type* #,(id #'stem #'< #'stem #'>) - #,(id #'stem #'% #'stem) - #,(id #'stem #'make- #'stem) - #,(id #'stem #'stem #'?) - (field field-getter (default def)) - ...) - (define #,(id #'stem #'stem #'-fields) - (list (configuration-field - (name 'field) - (type 'field-type) - (getter field-getter) - (predicate field-predicate) - (serializer field-serializer) - (default-value-thunk (lambda () def)) - (documentation doc)) - ...)) - (define-syntax-rule (stem arg (... ...)) - (let ((conf (#,(id #'stem #'% #'stem) arg (... ...)))) - (validate-configuration conf - #,(id #'stem #'stem #'-fields)) - conf)))))))) - (define %cups-accounts (list (user-group (name "lp") (system? #t)) (user-group (name "lpadmin") (system? #t)) @@ -147,24 +56,6 @@ (home-directory "/var/empty") (shell (file-append shadow "/sbin/nologin"))))) -(define (uglify-field-name field-name) - (let ((str (symbol->string field-name))) - (string-concatenate - (map string-titlecase - (string-split (if (string-suffix? "?" str) - (substring str 0 (1- (string-length str))) - str) - #\-))))) - -(define (serialize-field field-name val) - (format #t "~a ~a\n" (uglify-field-name field-name) val)) - -(define (serialize-package field-name val) - #f) - -(define (serialize-string field-name val) - (serialize-field field-name val)) - (define (multiline-string-list? val) (and (list? val) (and-map (lambda (x) @@ -173,28 +64,11 @@ (define (serialize-multiline-string-list field-name val) (for-each (lambda (str) (serialize-field field-name str)) val)) -(define (space-separated-string-list? val) - (and (list? val) - (and-map (lambda (x) - (and (string? x) (not (string-index x #\space)))) - val))) -(define (serialize-space-separated-string-list field-name val) - (serialize-field field-name (string-join val " "))) - (define (space-separated-symbol-list? val) (and (list? val) (and-map symbol? val))) (define (serialize-space-separated-symbol-list field-name val) (serialize-field field-name (string-join (map symbol->string val) " "))) -(define (file-name? val) - (and (string? val) - (string-prefix? "/" val))) -(define (serialize-file-name field-name val) - (serialize-string field-name val)) - -(define (serialize-boolean field-name val) - (serialize-string field-name (if val "yes" "no"))) - (define (non-negative-integer? val) (and (exact-integer? val) (not (negative? val)))) (define (serialize-non-negative-integer field-name val) @@ -333,7 +207,7 @@ methods. Otherwise apply to only the listed methods.") (define-configuration location-access-control (path - (file-name (cups-configuration-missing-field 'location-access-control 'path)) + (file-name (configuration-missing-field 'location-access-control 'path)) "Specifies the URI path to which the access control applies.") (access-controls (access-control-list '()) @@ -359,7 +233,7 @@ methods. Otherwise apply to only the listed methods.") (define-configuration policy-configuration (name - (string (cups-configuration-missing-field 'policy-configuration 'name)) + (string (configuration-missing-field 'policy-configuration 'name)) "Name of the policy.") (job-private-access (string "@OWNER @SYSTEM") @@ -925,12 +799,12 @@ IPP specifications.") (package-list '()) "Drivers and other extensions to the CUPS package.") (cupsd.conf - (string (cups-configuration-missing-field 'opaque-cups-configuration - 'cupsd.conf)) + (string (configuration-missing-field 'opaque-cups-configuration + 'cupsd.conf)) "The contents of the @code{cupsd.conf} to use.") (cups-files.conf - (string (cups-configuration-missing-field 'opaque-cups-configuration - 'cups-files.conf)) + (string (configuration-missing-field 'opaque-cups-configuration + 'cups-files.conf)) "The contents of the @code{cups-files.conf} to use.")) (define %cups-activation @@ -1117,8 +991,8 @@ extensions that it uses." extensions))))))))) ;; A little helper to make it easier to document all those fields. -(define (generate-documentation) - (define documentation +(define (generate-cups-documentation) + (generate-documentation `((cups-configuration ,cups-configuration-fields (files-configuration files-configuration) @@ -1132,35 +1006,5 @@ extensions that it uses." ,location-access-control-fields (method-access-controls method-access-controls)) (operation-access-controls ,operation-access-control-fields) - (method-access-controls ,method-access-control-fields))) - (define (str x) (object->string x)) - (define (generate configuration-name) - (match (assq-ref documentation configuration-name) - ((fields . sub-documentation) - `((para "Available " (code ,(str configuration-name)) " fields are:") - ,@(map - (lambda (f) - (let ((field-name (configuration-field-name f)) - (field-type (configuration-field-type f)) - (field-docs (cdr (texi-fragment->stexi - (configuration-field-documentation f)))) - (default (catch #t - (configuration-field-default-value-thunk f) - (lambda _ '%invalid)))) - (define (show-default? val) - (or (string? default) (number? default) (boolean? default) - (and (symbol? val) (not (eq? val '%invalid))) - (and (list? val) (and-map show-default? val)))) - `(deftypevr (% (category - (code ,(str configuration-name)) " parameter") - (data-type ,(str field-type)) - (name ,(str field-name))) - ,@field-docs - ,@(if (show-default? default) - `((para "Defaults to " (samp ,(str default)) ".")) - '()) - ,@(append-map - generate - (or (assq-ref sub-documentation field-name) '()))))) - fields))))) - (stexi->texi `(*fragment* . ,(generate 'cups-configuration)))) + (method-access-controls ,method-access-control-fields)) + 'cups-configuration)) diff --git a/gnu/services/dbus.scm b/gnu/services/dbus.scm index 876f56d45f..26390a4acd 100644 --- a/gnu/services/dbus.scm +++ b/gnu/services/dbus.scm @@ -21,7 +21,9 @@ #:use-module (gnu services) #:use-module (gnu services shepherd) #:use-module (gnu system shadow) + #:use-module (gnu system pam) #:use-module ((gnu packages glib) #:select (dbus)) + #:use-module (gnu packages polkit) #:use-module (gnu packages admin) #:use-module (guix gexp) #:use-module (guix records) @@ -30,7 +32,10 @@ #:export (dbus-configuration dbus-configuration? dbus-root-service-type - dbus-service)) + dbus-service + + polkit-service-type + polkit-service)) ;;; ;;; D-Bus. @@ -218,4 +223,91 @@ and policy files. For example, to allow avahi-daemon to use the system bus, (dbus-configuration (dbus dbus) (services services)))) + +;;; +;;; Polkit privilege management service. +;;; + +(define-record-type* <polkit-configuration> + polkit-configuration make-polkit-configuration + polkit-configuration? + (polkit polkit-configuration-polkit ;<package> + (default polkit)) + (actions polkit-configuration-actions ;list of <package> + (default '()))) + +(define %polkit-accounts + (list (user-group (name "polkitd") (system? #t)) + (user-account + (name "polkitd") + (group "polkitd") + (system? #t) + (comment "Polkit daemon user") + (home-directory "/var/empty") + (shell "/run/current-system/profile/sbin/nologin")))) + +(define %polkit-pam-services + (list (unix-pam-service "polkit-1"))) + +(define (polkit-directory packages) + "Return a directory containing an @file{actions} and possibly a +@file{rules.d} sub-directory, for use as @file{/etc/polkit-1}." + (with-imported-modules '((guix build union)) + (computed-file "etc-polkit-1" + #~(begin + (use-modules (guix build union) (srfi srfi-26)) + + (union-build #$output + (map (cut string-append <> + "/share/polkit-1") + (list #$@packages))))))) + +(define polkit-etc-files + (match-lambda + (($ <polkit-configuration> polkit packages) + `(("polkit-1" ,(polkit-directory (cons polkit packages))))))) + +(define polkit-setuid-programs + (match-lambda + (($ <polkit-configuration> polkit) + (list (file-append polkit "/lib/polkit-1/polkit-agent-helper-1") + (file-append polkit "/bin/pkexec"))))) + +(define polkit-service-type + (service-type (name 'polkit) + (extensions + (list (service-extension account-service-type + (const %polkit-accounts)) + (service-extension pam-root-service-type + (const %polkit-pam-services)) + (service-extension dbus-root-service-type + (compose + list + polkit-configuration-polkit)) + (service-extension etc-service-type + polkit-etc-files) + (service-extension setuid-program-service-type + polkit-setuid-programs))) + + ;; Extensions are lists of packages that provide polkit rules + ;; or actions under share/polkit-1/{actions,rules.d}. + (compose concatenate) + (extend (lambda (config actions) + (polkit-configuration + (inherit config) + (actions + (append (polkit-configuration-actions config) + actions))))))) + +(define* (polkit-service #:key (polkit polkit)) + "Return a service that runs the +@uref{http://www.freedesktop.org/wiki/Software/polkit/, Polkit privilege +management service}, which allows system administrators to grant access to +privileged operations in a structured way. By querying the Polkit service, a +privileged system component can know when it should grant additional +capabilities to ordinary users. For example, an ordinary user can be granted +the capability to suspend the system if the user is logged in locally." + (service polkit-service-type + (polkit-configuration (polkit polkit)))) + ;;; dbus.scm ends here diff --git a/gnu/services/desktop.scm b/gnu/services/desktop.scm index dfd1ea6e92..7555780ade 100644 --- a/gnu/services/desktop.scm +++ b/gnu/services/desktop.scm @@ -37,7 +37,6 @@ #:use-module (gnu packages gnome) #:use-module (gnu packages xfce) #:use-module (gnu packages avahi) - #:use-module (gnu packages polkit) #:use-module (gnu packages xdisorg) #:use-module (gnu packages suckless) #:use-module (gnu packages linux) @@ -68,11 +67,6 @@ bluetooth-service - polkit-configuration - polkit-configuration? - polkit-service - polkit-service-type - elogind-configuration elogind-configuration? elogind-service @@ -415,93 +409,6 @@ Users need to be in the @code{lp} group to access the D-Bus service. ;;; -;;; Polkit privilege management service. -;;; - -(define-record-type* <polkit-configuration> - polkit-configuration make-polkit-configuration - polkit-configuration? - (polkit polkit-configuration-polkit ;<package> - (default polkit)) - (actions polkit-configuration-actions ;list of <package> - (default '()))) - -(define %polkit-accounts - (list (user-group (name "polkitd") (system? #t)) - (user-account - (name "polkitd") - (group "polkitd") - (system? #t) - (comment "Polkit daemon user") - (home-directory "/var/empty") - (shell "/run/current-system/profile/sbin/nologin")))) - -(define %polkit-pam-services - (list (unix-pam-service "polkit-1"))) - -(define (polkit-directory packages) - "Return a directory containing an @file{actions} and possibly a -@file{rules.d} sub-directory, for use as @file{/etc/polkit-1}." - (with-imported-modules '((guix build union)) - (computed-file "etc-polkit-1" - #~(begin - (use-modules (guix build union) (srfi srfi-26)) - - (union-build #$output - (map (cut string-append <> - "/share/polkit-1") - (list #$@packages))))))) - -(define polkit-etc-files - (match-lambda - (($ <polkit-configuration> polkit packages) - `(("polkit-1" ,(polkit-directory (cons polkit packages))))))) - -(define polkit-setuid-programs - (match-lambda - (($ <polkit-configuration> polkit) - (list (file-append polkit "/lib/polkit-1/polkit-agent-helper-1") - (file-append polkit "/bin/pkexec"))))) - -(define polkit-service-type - (service-type (name 'polkit) - (extensions - (list (service-extension account-service-type - (const %polkit-accounts)) - (service-extension pam-root-service-type - (const %polkit-pam-services)) - (service-extension dbus-root-service-type - (compose - list - polkit-configuration-polkit)) - (service-extension etc-service-type - polkit-etc-files) - (service-extension setuid-program-service-type - polkit-setuid-programs))) - - ;; Extensions are lists of packages that provide polkit rules - ;; or actions under share/polkit-1/{actions,rules.d}. - (compose concatenate) - (extend (lambda (config actions) - (polkit-configuration - (inherit config) - (actions - (append (polkit-configuration-actions config) - actions))))))) - -(define* (polkit-service #:key (polkit polkit)) - "Return a service that runs the -@uref{http://www.freedesktop.org/wiki/Software/polkit/, Polkit privilege -management service}, which allows system administrators to grant access to -privileged operations in a structured way. By querying the Polkit service, a -privileged system component can know when it should grant additional -capabilities to ordinary users. For example, an ordinary user can be granted -the capability to suspend the system if the user is logged in locally." - (service polkit-service-type - (polkit-configuration (polkit polkit)))) - - -;;; ;;; Colord D-Bus service. ;;; diff --git a/gnu/services/kerberos.scm b/gnu/services/kerberos.scm index 144c71bba0..a56f63082c 100644 --- a/gnu/services/kerberos.scm +++ b/gnu/services/kerberos.scm @@ -38,15 +38,17 @@ "Return a PAM service for Kerberos authentication." (lambda (pam) (define pam-krb5-module - #~(string-append #$(pam-krb5-configuration-pam-krb5 config) "/lib/security/pam_krb5.so")) + #~(string-append #$(pam-krb5-configuration-pam-krb5 config) + "/lib/security/pam_krb5.so")) (let ((pam-krb5-sufficient (pam-entry (control "sufficient") (module pam-krb5-module) - (arguments (list - (format #f "minimum_uid=~a" - (pam-krb5-configuration-minimum-uid config))))))) + (arguments + (list + (format #f "minimum_uid=~a" + (pam-krb5-configuration-minimum-uid config))))))) (pam-service (inherit pam) (auth (cons* pam-krb5-sufficient diff --git a/gnu/services/mail.scm b/gnu/services/mail.scm index cb0f119f43..c1381405d8 100644 --- a/gnu/services/mail.scm +++ b/gnu/services/mail.scm @@ -21,6 +21,7 @@ (define-module (gnu services mail) #:use-module (gnu services) #:use-module (gnu services base) + #:use-module (gnu services configuration) #:use-module (gnu services shepherd) #:use-module (gnu system pam) #:use-module (gnu system shadow) @@ -30,13 +31,8 @@ #:use-module (guix records) #:use-module (guix packages) #:use-module (guix gexp) - #:use-module (srfi srfi-34) - #:use-module (srfi srfi-35) #:use-module (ice-9 match) - #:export (&dovecot-configuation-error - dovecot-configuration-error? - - dovecot-service + #:export (dovecot-service dovecot-service-type dovecot-configuration opaque-dovecot-configuration @@ -51,7 +47,12 @@ protocol-configuration plugin-configuration mailbox-configuration - namespace-configuration)) + namespace-configuration + + opensmtpd-configuration + opensmtpd-configuration? + opensmtpd-service-type + %default-opensmtpd-config-file)) ;;; Commentary: ;;; @@ -60,112 +61,6 @@ ;;; ;;; Code: -(define-condition-type &dovecot-configuration-error &error - dovecot-configuration-error?) - -(define (dovecot-error message) - (raise (condition (&message (message message)) - (&dovecot-configuration-error)))) -(define (dovecot-configuration-field-error field val) - (dovecot-error - (format #f "Invalid value for field ~a: ~s" field val))) -(define (dovecot-configuration-missing-field kind field) - (dovecot-error - (format #f "~a configuration missing required field ~a" kind field))) - -(define-record-type* <configuration-field> - configuration-field make-configuration-field configuration-field? - (name configuration-field-name) - (type configuration-field-type) - (getter configuration-field-getter) - (predicate configuration-field-predicate) - (serializer configuration-field-serializer) - (default-value-thunk configuration-field-default-value-thunk) - (documentation configuration-field-documentation)) - -(define-syntax define-configuration - (lambda (stx) - (define (id ctx part . parts) - (let ((part (syntax->datum part))) - (datum->syntax - ctx - (match parts - (() part) - (parts (symbol-append part - (syntax->datum (apply id ctx parts)))))))) - (syntax-case stx () - ((_ stem (field (field-type def) doc) ...) - (with-syntax (((field-getter ...) - (map (lambda (field) - (id #'stem #'stem #'- field)) - #'(field ...))) - ((field-predicate ...) - (map (lambda (type) - (id #'stem type #'?)) - #'(field-type ...))) - ((field-serializer ...) - (map (lambda (type) - (id #'stem #'serialize- type)) - #'(field-type ...)))) - #`(begin - (define-record-type* #,(id #'stem #'< #'stem #'>) - stem #,(id #'stem #'make- #'stem) #,(id #'stem #'stem #'?) - (field field-getter (default def)) - ...) - (define #,(id #'stem #'stem #'-fields) - (list (configuration-field - (name 'field) - (type 'field-type) - (getter field-getter) - (predicate field-predicate) - (serializer field-serializer) - (default-value-thunk (lambda () def)) - (documentation doc)) - ...)))))))) - -(define (serialize-configuration config fields) - (for-each (lambda (field) - ((configuration-field-serializer field) - (configuration-field-name field) - ((configuration-field-getter field) config))) - fields)) - -(define (validate-configuration config fields) - (for-each (lambda (field) - (let ((val ((configuration-field-getter field) config))) - (unless ((configuration-field-predicate field) val) - (dovecot-configuration-field-error - (configuration-field-name field) val)))) - fields)) - -(define (validate-package field-name package) - (unless (package? package) - (dovecot-configuration-field-error field-name package))) - -(define (uglify-field-name field-name) - (let ((str (symbol->string field-name))) - (string-join (string-split (if (string-suffix? "?" str) - (substring str 0 (1- (string-length str))) - str) - #\-) - "_"))) - -(define (serialize-package field-name val) - #f) - -(define (serialize-field field-name val) - (format #t "~a=~a\n" (uglify-field-name field-name) val)) - -(define (serialize-string field-name val) - (serialize-field field-name val)) - -(define (space-separated-string-list? val) - (and (list? val) - (and-map (lambda (x) - (and (string? x) (not (string-index x #\space)))) - val))) -(define (serialize-space-separated-string-list field-name val) - (serialize-field field-name (string-join val " "))) (define (comma-separated-string-list? val) (and (list? val) @@ -175,12 +70,6 @@ (define (serialize-comma-separated-string-list field-name val) (serialize-field field-name (string-join val ","))) -(define (file-name? val) - (and (string? val) - (string-prefix? "/" val))) -(define (serialize-file-name field-name val) - (serialize-string field-name val)) - (define (colon-separated-file-name-list? val) (and (list? val) ;; Trailing slashes not needed and not @@ -188,9 +77,6 @@ (define (serialize-colon-separated-file-name-list field-name val) (serialize-field field-name (string-join val ":"))) -(define (serialize-boolean field-name val) - (serialize-string field-name (if val "yes" "no"))) - (define (non-negative-integer? val) (and (exact-integer? val) (not (negative? val)))) (define (serialize-non-negative-integer field-name val) @@ -271,7 +157,7 @@ (define-configuration unix-listener-configuration (path - (file-name (dovecot-configuration-missing-field 'unix-listener 'path)) + (file-name (configuration-missing-field 'unix-listener 'path)) "The file name on which to listen.") (mode (string "0600") @@ -290,7 +176,7 @@ (define-configuration fifo-listener-configuration (path - (file-name (dovecot-configuration-missing-field 'fifo-listener 'path)) + (file-name (configuration-missing-field 'fifo-listener 'path)) "The file name on which to listen.") (mode (string "0600") @@ -309,14 +195,14 @@ (define-configuration inet-listener-configuration (protocol - (string (dovecot-configuration-missing-field 'inet-listener 'protocol)) + (string (configuration-missing-field 'inet-listener 'protocol)) "The protocol to listen for.") (address (string "") "The address on which to listen, or empty for all addresses.") (port (non-negative-integer - (dovecot-configuration-missing-field 'inet-listener 'port)) + (configuration-missing-field 'inet-listener 'port)) "The port on which to listen.") (ssl? (boolean #t) @@ -340,7 +226,7 @@ (serialize-fifo-listener-configuration field-name val)) ((inet-listener-configuration? val) (serialize-inet-listener-configuration field-name val)) - (else (dovecot-configuration-field-error field-name val)))) + (else (configuration-field-error field-name val)))) (define (listener-configuration-list? val) (and (list? val) (and-map listener-configuration? val))) (define (serialize-listener-configuration-list field-name val) @@ -350,7 +236,7 @@ (define-configuration service-configuration (kind - (string (dovecot-configuration-missing-field 'service 'kind)) + (string (configuration-missing-field 'service 'kind)) "The service kind. Valid values include @code{director}, @code{imap-login}, @code{pop3-login}, @code{lmtp}, @code{imap}, @code{pop3}, @code{auth}, @code{auth-worker}, @code{dict}, @@ -388,7 +274,7 @@ this.")) (define-configuration protocol-configuration (name - (string (dovecot-configuration-missing-field 'protocol 'name)) + (string (configuration-missing-field 'protocol 'name)) "The name of the protocol.") (auth-socket-path (string "/var/run/dovecot/auth-userdb") @@ -1492,8 +1378,8 @@ greyed out, instead of only later giving \"not selectable\" popup error. "The dovecot package.") (string - (string (dovecot-configuration-missing-field 'opaque-dovecot-configuration - 'string)) + (string (configuration-missing-field 'opaque-dovecot-configuration + 'string)) "The contents of the @code{dovecot.conf} to use.")) (define %dovecot-accounts @@ -1629,8 +1515,8 @@ by @code{dovecot-configuration}. @var{config} may also be created by (service dovecot-service-type config)) ;; A little helper to make it easier to document all those fields. -(define (generate-documentation) - (define documentation +(define (generate-dovecot-documentation) + (generate-documentation `((dovecot-configuration ,dovecot-configuration-fields (dict dict-configuration) @@ -1655,39 +1541,80 @@ by @code{dovecot-configuration}. @var{config} may also be created by ,service-configuration-fields (listeners unix-listener-configuration fifo-listener-configuration inet-listener-configuration)) - (protocol-configuration ,protocol-configuration-fields))) - (define (generate configuration-name) - (match (assq-ref documentation configuration-name) - ((fields . sub-documentation) - (format #t "\nAvailable @code{~a} fields are:\n\n" configuration-name) - (for-each - (lambda (f) - (let ((field-name (configuration-field-name f)) - (field-type (configuration-field-type f)) - (field-docs (string-trim-both - (configuration-field-documentation f))) - (default (catch #t - (configuration-field-default-value-thunk f) - (lambda _ 'nope)))) - (define (escape-chars str chars escape) - (with-output-to-string - (lambda () - (string-for-each (lambda (c) - (when (char-set-contains? chars c) - (display escape)) - (display c)) - str)))) - (define (show-default? val) - (or (string? default) (number? default) (boolean? default) - (and (list? val) (and-map show-default? val)))) - (format #t "@deftypevr {@code{~a} parameter} ~a ~a\n~a\n" - configuration-name field-type field-name field-docs) - (when (show-default? default) - (format #t "Defaults to @samp{~a}.\n" - (escape-chars (format #f "~s" default) - (char-set #\@ #\{ #\}) - #\@))) - (for-each generate (or (assq-ref sub-documentation field-name) '())) - (format #t "@end deftypevr\n\n"))) - fields)))) - (generate 'dovecot-configuration)) + (protocol-configuration ,protocol-configuration-fields)) + 'dovecot-configuration)) + + +;;; +;;; OpenSMTPD. +;;; + +(define-record-type* <opensmtpd-configuration> + opensmtpd-configuration make-opensmtpd-configuration + opensmtpd-configuration? + (package opensmtpd-configuration-package + (default opensmtpd)) + (config-file opensmtpd-configuration-config-file + (default %default-opensmtpd-config-file))) + +(define %default-opensmtpd-config-file + (plain-file "smtpd.conf" " +listen on lo +accept from any for local deliver to mbox +accept from local for any relay +")) + +(define opensmtpd-shepherd-service + (match-lambda + (($ <opensmtpd-configuration> package config-file) + (list (shepherd-service + (provision '(smtpd)) + (requirement '(loopback)) + (documentation "Run the OpenSMTPD daemon.") + (start (let ((smtpd (file-append package "/sbin/smtpd"))) + #~(make-forkexec-constructor + (list #$smtpd "-f" #$config-file) + #:pid-file "/var/run/smtpd.pid"))) + (stop #~(make-kill-destructor))))))) + +(define %opensmtpd-accounts + (list (user-group + (name "smtpq") + (system? #t)) + (user-account + (name "smtpd") + (group "nogroup") + (system? #t) + (comment "SMTP Daemon") + (home-directory "/var/empty") + (shell (file-append shadow "/sbin/nologin"))) + (user-account + (name "smtpq") + (group "smtpq") + (system? #t) + (comment "SMTPD Queue") + (home-directory "/var/empty") + (shell (file-append shadow "/sbin/nologin"))))) + +(define opensmtpd-activation + (match-lambda + (($ <opensmtpd-configuration> package config-file) + (let ((smtpd (file-append package "/sbin/smtpd"))) + #~(begin + ;; Create mbox and spool directories. + (mkdir-p "/var/mail") + (mkdir-p "/var/spool/smtpd") + (chmod "/var/spool/smtpd" #o711)))))) + +(define opensmtpd-service-type + (service-type + (name 'opensmtpd) + (extensions + (list (service-extension account-service-type + (const %opensmtpd-accounts)) + (service-extension activation-service-type + opensmtpd-activation) + (service-extension profile-service-type + (compose list opensmtpd-configuration-package)) + (service-extension shepherd-root-service-type + opensmtpd-shepherd-service))))) diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm index 5a83240d77..bbb9053008 100644 --- a/gnu/services/networking.scm +++ b/gnu/services/networking.scm @@ -682,7 +682,7 @@ and @command{wicd-curses} user interfaces." (list (shepherd-service (documentation "Run the NetworkManager.") (provision '(networking)) - (requirement '(user-processes dbus-system loopback)) + (requirement '(user-processes dbus-system wpa-supplicant loopback)) (start #~(make-forkexec-constructor (list (string-append #$network-manager "/sbin/NetworkManager") @@ -695,6 +695,7 @@ and @command{wicd-curses} user interfaces." (list (service-extension shepherd-root-service-type network-manager-shepherd-service) (service-extension dbus-root-service-type list) + (service-extension polkit-service-type list) (service-extension activation-service-type (const %network-manager-activation)) ;; Add network-manager to the system profile. diff --git a/gnu/system/examples/desktop.tmpl b/gnu/system/examples/desktop.tmpl index 2fcf90f8b1..82687e740b 100644 --- a/gnu/system/examples/desktop.tmpl +++ b/gnu/system/examples/desktop.tmpl @@ -1,5 +1,6 @@ ;; This is an operating system configuration template -;; for a "desktop" setup with GNOME and Xfce. +;; for a "desktop" setup with GNOME and Xfce where the +;; root partition is encrypted with LUKS. (use-modules (gnu) (gnu system nss)) (use-service-modules desktop) @@ -13,11 +14,21 @@ ;; Assuming /dev/sdX is the target hard disk, and "my-root" ;; is the label of the target root file system. (bootloader (grub-configuration (device "/dev/sdX"))) + + ;; Specify a mapped device for the encrypted root partition. + ;; The UUID is that returned by 'cryptsetup luksUUID'. + (mapped-devices + (list (mapped-device + (source (uuid "12345678-1234-1234-1234-123456789abc")) + (target "the-root-device") + (type luks-device-mapping)))) + (file-systems (cons (file-system (device "my-root") (title 'label) (mount-point "/") - (type "ext4")) + (type "ext4") + (dependencies mapped-devices)) %base-file-systems)) (users (cons (user-account diff --git a/gnu/system/mapped-devices.scm b/gnu/system/mapped-devices.scm index e44f2693a7..8ab861bf73 100644 --- a/gnu/system/mapped-devices.scm +++ b/gnu/system/mapped-devices.scm @@ -23,7 +23,7 @@ #:use-module (guix modules) #:use-module (gnu services) #:use-module (gnu services shepherd) - #:autoload (gnu packages cryptsetup) (cryptsetup) + #:autoload (gnu packages cryptsetup) (cryptsetup-static) #:autoload (gnu packages linux) (mdadm-static) #:use-module (srfi srfi-1) #:use-module (ice-9 match) @@ -104,7 +104,9 @@ ((gnu build file-systems) #:select (find-partition-by-luks-uuid))) - (zero? (system* (string-append #$cryptsetup "/sbin/cryptsetup") + ;; Use 'cryptsetup-static', not 'cryptsetup', to avoid pulling the + ;; whole world inside the initrd (for when we're in an initrd). + (zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup") "open" "--type" "luks" ;; Note: We cannot use the "UUID=source" syntax here @@ -120,7 +122,7 @@ (define (close-luks-device source target) "Return a gexp that closes TARGET, a LUKS device." - #~(zero? (system* (string-append #$cryptsetup "/sbin/cryptsetup") + #~(zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup") "close" #$target))) (define luks-device-mapping diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm index 9a265309c0..6370d6951b 100644 --- a/gnu/tests/base.scm +++ b/gnu/tests/base.scm @@ -31,6 +31,8 @@ #:use-module (gnu services mcron) #:use-module (gnu services shepherd) #:use-module (gnu services networking) + #:use-module (gnu packages imagemagick) + #:use-module (gnu packages ocr) #:use-module (guix gexp) #:use-module (guix store) #:use-module (guix monads) @@ -65,10 +67,16 @@ %base-user-accounts)))) -(define* (run-basic-test os command #:optional (name "basic")) +(define* (run-basic-test os command #:optional (name "basic") + #:key initialization) "Return a derivation called NAME that tests basic features of the OS started using COMMAND, a gexp that evaluates to a list of strings. Compare some -properties of running system to what's declared in OS, an <operating-system>." +properties of running system to what's declared in OS, an <operating-system>. + +When INITIALIZATION is true, it must be a one-argument procedure that is +passed a gexp denoting the marionette, and it must return gexp that is +inserted before the first test. This is used to introduce an extra +initialization step, such as entering a LUKS passphrase." (define test (with-imported-modules '((gnu build marionette)) #~(begin @@ -86,6 +94,9 @@ properties of running system to what's declared in OS, an <operating-system>." (test-begin "basic") + #$(and initialization + (initialization #~marionette)) + (test-assert "uname" (match (marionette-eval '(uname) marionette) (#("Linux" host-name version _ architecture) @@ -188,14 +199,8 @@ info --version") (test-equal "locale" "en_US.utf8" - (marionette-eval '(begin - ;; XXX: This 'setenv' call wouldn't be needed - ;; but our glibc@2.23 currently ignores - ;; /run/current-system/locale. - (setenv "GUIX_LOCPATH" - "/run/current-system/locale") - (let ((before (setlocale LC_ALL "en_US.utf8"))) - (setlocale LC_ALL before))) + (marionette-eval '(let ((before (setlocale LC_ALL "en_US.utf8"))) + (setlocale LC_ALL before)) marionette)) (test-assert "/run/current-system is a GC root" @@ -241,6 +246,20 @@ info --version") marionette) (file-exists? "tty1.ppm"))) + (test-assert "screen text" + (let ((text (marionette-screen-text marionette + #:ocrad + #$(file-append ocrad + "/bin/ocrad")))) + ;; Check whether the welcome message and shell prompt are + ;; displayed. Note: OCR confuses "y" and "V" for instance, so + ;; we cannot reliably match the whole text. + (and (string-contains text "This is the GNU") + (string-contains text + (string-append + "root@" + #$(operating-system-host-name os)))))) + (test-end) (exit (= (test-runner-fail-count (test-runner-current)) 0))))) diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm index 98f8649af8..ecf1ac1923 100644 --- a/gnu/tests/install.scm +++ b/gnu/tests/install.scm @@ -24,6 +24,7 @@ #:use-module (gnu system install) #:use-module (gnu system vm) #:use-module ((gnu build vm) #:select (qemu-command)) + #:use-module (gnu packages ocr) #:use-module (gnu packages qemu) #:use-module (gnu packages package-management) #:use-module (guix store) @@ -398,17 +399,20 @@ by 'mdadm'.") (locale "en_US.UTF-8") (bootloader (grub-configuration (device "/dev/vdb"))) - (kernel-arguments '("console=ttyS0")) + + ;; Note: Do not pass "console=ttyS0" so we can use our passphrase prompt + ;; detection logic in 'enter-luks-passphrase'. + + (mapped-devices (list (mapped-device + (source (uuid "12345678-1234-1234-1234-123456789abc")) + (target "the-root-device") + (type luks-device-mapping)))) (file-systems (cons (file-system (device "/dev/mapper/the-root-device") (title 'device) (mount-point "/") (type "ext4")) %base-file-systems)) - (mapped-devices (list (mapped-device - (source "REPLACE-WITH-LUKS-UUID") - (target "the-root-device") - (type luks-device-mapping)))) (users (cons (user-account (name "charlie") (group "users") @@ -435,7 +439,8 @@ parted --script /dev/vdb mklabel gpt \\ mkpart primary ext2 3M 1G \\ set 1 boot on \\ set 1 bios_grub on -echo -n thepassphrase | cryptsetup luksFormat -q /dev/vdb2 - +echo -n thepassphrase | \\ + cryptsetup luksFormat --uuid=12345678-1234-1234-1234-123456789abc -q /dev/vdb2 - echo -n thepassphrase | \\ cryptsetup open --type luks --key-file - /dev/vdb2 the-root-device mkfs.ext4 -L my-root /dev/mapper/the-root-device @@ -443,15 +448,53 @@ mount LABEL=my-root /mnt herd start cow-store /mnt mkdir /mnt/etc cp /etc/target-config.scm /mnt/etc/config.scm -cat /mnt/etc/config -luks_uuid=`cryptsetup luksUUID /dev/vdb2` -sed -i /mnt/etc/config.scm \\ - -e \"s/\\\"REPLACE-WITH-LUKS-UUID\\\"/(uuid \\\"$luks_uuid\\\")/g\" guix system build /mnt/etc/config.scm guix system init /mnt/etc/config.scm /mnt --no-substitutes sync reboot\n") +(define (enter-luks-passphrase marionette) + "Return a gexp to be inserted in the basic system test running on MARIONETTE +to enter the LUKS passphrase." + (let ((ocrad (file-append ocrad "/bin/ocrad"))) + #~(begin + (define (passphrase-prompt? text) + (string-contains (pk 'screen-text text) "Enter pass")) + + (define (bios-boot-screen? text) + ;; Return true if TEXT corresponds to the boot screen, before GRUB's + ;; menu. + (string-prefix? "SeaBIOS" text)) + + (test-assert "enter LUKS passphrase for GRUB" + (begin + ;; At this point we have no choice but to use OCR to determine + ;; when the passphrase should be entered. + (wait-for-screen-text #$marionette passphrase-prompt? + #:ocrad #$ocrad) + (marionette-type "thepassphrase\n" #$marionette) + + ;; Now wait until we leave the boot screen. This is necessary so + ;; we can then be sure we match the "Enter passphrase" prompt from + ;; 'cryptsetup', in the initrd. + (wait-for-screen-text #$marionette (negate bios-boot-screen?) + #:ocrad #$ocrad + #:timeout 20))) + + (test-assert "enter LUKS passphrase for the initrd" + (begin + ;; XXX: Here we use OCR as well but we could instead use QEMU + ;; '-serial stdio' and run it in an input pipe, + (wait-for-screen-text #$marionette passphrase-prompt? + #:ocrad #$ocrad + #:timeout 60) + (marionette-type "thepassphrase\n" #$marionette) + + ;; Take a screenshot for debugging purposes. + (marionette-control (string-append "screendump " #$output + "/post-initrd-passphrase.ppm") + #$marionette)))))) + (define %test-encrypted-os (system-test (name "encrypted-root-os") @@ -465,6 +508,7 @@ build (current-guix) and then store a couple of full system images.") #:script %encrypted-root-installation-script)) (command (qemu-command/writable-image image))) - (run-basic-test %encrypted-root-os command "encrypted-root-os"))))) + (run-basic-test %encrypted-root-os command "encrypted-root-os" + #:initialization enter-luks-passphrase))))) ;;; install.scm ends here diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 33d141e7ef..2e0268020c 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -17,6 +17,13 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix scripts offload) + #:use-module (ssh key) + #:use-module (ssh auth) + #:use-module (ssh session) + #:use-module (ssh channel) + #:use-module (ssh popen) + #:use-module (ssh dist) + #:use-module (ssh dist node) #:use-module (guix config) #:use-module (guix records) #:use-module (guix store) @@ -65,14 +72,15 @@ (system build-machine-system) ; string (user build-machine-user) ; string (private-key build-machine-private-key ; file name - (default (user-lsh-private-key))) + (default (user-openssh-private-key))) + (host-key build-machine-host-key) ; string + (daemon-socket build-machine-daemon-socket ; string + (default "/var/guix/daemon-socket/socket")) (parallel-builds build-machine-parallel-builds ; number (default 1)) (speed build-machine-speed ; inexact real (default 1.0)) (features build-machine-features ; list of strings - (default '())) - (ssh-options build-machine-ssh-options ; list of strings (default '()))) (define-record-type* <build-requirements> @@ -86,19 +94,11 @@ ;; File that lists machines available as build slaves. (string-append %config-directory "/machines.scm")) -(define %lsh-command - "lsh") - -(define %lshg-command - ;; FIXME: 'lshg' fails to pass large amounts of data, see - ;; <http://lists.lysator.liu.se/pipermail/lsh-bugs/2014q1/000639.html>. - "lsh") - -(define (user-lsh-private-key) - "Return the user's default lsh private key, or #f if it could not be +(define (user-openssh-private-key) + "Return the user's default SSH private key, or #f if it could not be determined." (and=> (getenv "HOME") - (cut string-append <> "/.lsh/identity"))) + (cut string-append <> "/.ssh/id_rsa"))) (define %user-module ;; Module in which the machine description file is loaded. @@ -134,81 +134,120 @@ determined." (leave (_ "failed to load machine file '~a': ~s~%") file args)))))) -;;; FIXME: The idea was to open the connection to MACHINE once for all, but -;;; lshg is currently non-functional. -;; (define (open-ssh-gateway machine) -;; "Initiate an SSH connection gateway to MACHINE, and return the PID of the -;; running lsh gateway upon success, or #f on failure." -;; (catch 'system-error -;; (lambda () -;; (let* ((port (open-pipe* OPEN_READ %lsh-command -;; "-l" (build-machine-user machine) -;; "-i" (build-machine-private-key machine) -;; ;; XXX: With lsh 2.1, passing '--write-pid' -;; ;; last causes the PID not to be printed. -;; "--write-pid" "--gateway" "--background" -;; (build-machine-name machine))) -;; (line (read-line port)) -;; (status (close-pipe port))) -;; (if (zero? status) -;; (let ((pid (string->number line))) -;; (if (integer? pid) -;; pid -;; (begin -;; (warning (_ "'~a' did not write its PID on stdout: ~s~%") -;; %lsh-command line) -;; #f))) -;; (begin -;; (warning (_ "failed to initiate SSH connection to '~a':\ -;; '~a' exited with ~a~%") -;; (build-machine-name machine) -;; %lsh-command -;; (status:exit-val status)) -;; #f)))) -;; (lambda args -;; (leave (_ "failed to execute '~a': ~a~%") -;; %lsh-command (strerror (system-error-errno args)))))) - -(define-syntax with-error-to-port - (syntax-rules () - ((_ port exp0 exp ...) - (let ((new port) - (old (current-error-port))) - (dynamic-wind - (lambda () - (set-current-error-port new)) - (lambda () - exp0 exp ...) - (lambda () - (set-current-error-port old))))))) - -(define* (remote-pipe machine mode command - #:key (error-port (current-error-port)) (quote? #t)) - "Run COMMAND (a string list) on MACHINE, assuming an lsh gateway has been -set up. When QUOTE? is true, perform shell-quotation of all the elements of -COMMAND. Return either a pipe opened with MODE, or #f if the lsh client could -not be started." - (define (shell-quote str) - ;; Sort-of shell-quote STR so it can be passed as an argument to the - ;; shell. - (with-output-to-string - (lambda () - (write str)))) - - ;; Let the child inherit ERROR-PORT. - (with-error-to-port error-port - (apply open-pipe* mode %lshg-command - "-l" (build-machine-user machine) - "-p" (number->string (build-machine-port machine)) - - ;; XXX: Remove '-i' when %LSHG-COMMAND really is lshg. - "-i" (build-machine-private-key machine) - - (append (build-machine-ssh-options machine) - (list (build-machine-name machine)) - (if quote? - (map shell-quote command) - command))))) +(define (host-key->type+key host-key) + "Destructure HOST-KEY, an OpenSSH host key string, and return two values: +its key type as a symbol, and the actual base64-encoded string." + (define (type->symbol type) + (and (string-prefix? "ssh-" type) + (string->symbol (string-drop type 4)))) + + (match (string-tokenize host-key) + ((type key _) + (values (type->symbol type) key)) + ((type key) + (values (type->symbol type) key)))) + +(define (private-key-from-file* file) + "Like 'private-key-from-file', but raise an error that 'with-error-handling' +can interpret meaningfully." + (catch 'guile-ssh-error + (lambda () + (private-key-from-file file)) + (lambda (key proc str . rest) + (raise (condition + (&message (message (format #f (_ "failed to load SSH \ +private key from '~a': ~a") + file str)))))))) + +(define (open-ssh-session machine) + "Open an SSH session for MACHINE and return it. Throw an error on failure." + (let ((private (private-key-from-file* (build-machine-private-key machine))) + (public (public-key-from-file + (string-append (build-machine-private-key machine) + ".pub"))) + (session (make-session #:user (build-machine-user machine) + #:host (build-machine-name machine) + #:port (build-machine-port machine) + #:timeout 5 ;seconds + ;; #:log-verbosity 'protocol + #:identity (build-machine-private-key machine) + + ;; We need lightweight compression when + ;; exchanging full archives. + #:compression "zlib" + #:compression-level 3))) + (connect! session) + + ;; Authenticate the server. XXX: Guile-SSH 0.10.1 doesn't know about + ;; ed25519 keys and 'get-key-type' returns #f in that case. + (let-values (((server) (get-server-public-key session)) + ((type key) (host-key->type+key + (build-machine-host-key machine)))) + (unless (and (or (not (get-key-type server)) + (eq? (get-key-type server) type)) + (string=? (public-key->string server) key)) + ;; Key mismatch: something's wrong. XXX: It could be that the server + ;; provided its Ed25519 key when we where expecting its RSA key. + (leave (_ "server at '~a' returned host key '~a' of type '~a' \ +instead of '~a' of type '~a'~%") + (build-machine-name machine) + (public-key->string server) (get-key-type server) + key type))) + + (let ((auth (userauth-public-key! session private))) + (unless (eq? 'success auth) + (disconnect! session) + (leave (_ "SSH public key authentication failed for '~a': ~a~%") + (build-machine-name machine) (get-error session)))) + + session)) + +(define* (connect-to-remote-daemon session + #:optional + (socket-name "/var/guix/daemon-socket/socket")) + "Connect to the remote build daemon listening on SOCKET-NAME over SESSION, +an SSH session. Return a <nix-server> object." + (define redirect + ;; Code run in SESSION to redirect the remote process' stdin/stdout to the + ;; daemon's socket, à la socat. The SSH protocol supports forwarding to + ;; Unix-domain sockets but libssh doesn't have an API for that, hence this + ;; hack. + `(begin + (use-modules (ice-9 match) (rnrs io ports)) + + (let ((sock (socket AF_UNIX SOCK_STREAM 0)) + (stdin (current-input-port)) + (stdout (current-output-port))) + (setvbuf stdin _IONBF) + (setvbuf stdout _IONBF) + (connect sock AF_UNIX ,socket-name) + + (let loop () + (match (select (list stdin sock) '() (list stdin stdout sock)) + ((reads writes ()) + (when (memq stdin reads) + (match (get-bytevector-some stdin) + ((? eof-object?) + (primitive-exit 0)) + (bv + (put-bytevector sock bv)))) + (when (memq sock reads) + (match (get-bytevector-some sock) + ((? eof-object?) + (primitive-exit 0)) + (bv + (put-bytevector stdout bv)))) + (loop)) + (_ + (primitive-exit 1))))))) + + (let ((channel + (open-remote-pipe* session OPEN_BOTH + ;; Sort-of shell-quote REDIRECT. + "guile" "-c" + (object->string + (object->string redirect))))) + (open-connection #:port channel))) ;;; @@ -299,113 +338,6 @@ hook." (set-port-revealed! port 1) port)) -(define %gc-root-file - ;; File name of the temporary GC root we install. - (format #f "offload-~a-~a" (gethostname) (getpid))) - -(define (register-gc-root file machine) - "Mark FILE, a store item, as a garbage collector root on MACHINE." - (define script - `(begin - (use-modules (guix config)) - - ;; Note: we can't use 'add-indirect-root' because dangling links under - ;; gcroots/auto are automatically deleted by the GC. This strategy - ;; doesn't have this problem, but it requires write access to that - ;; directory. - (let ((root-directory (string-append %state-directory - "/gcroots/tmp"))) - (catch 'system-error - (lambda () - (mkdir root-directory)) - (lambda args - (unless (= EEXIST (system-error-errno args)) - (error "failed to create remote GC root directory" - root-directory (system-error-errno args))))) - - (catch 'system-error - (lambda () - (symlink ,file - (string-append root-directory "/" ,%gc-root-file))) - (lambda args - ;; If FILE already exists, we can assume that either it's a stale - ;; reference (which is fine), or another process is already - ;; building the derivation represented by FILE (which is fine - ;; too.) Thus, do nothing in that case. - (unless (= EEXIST (system-error-errno args)) - (apply throw args))))))) - - (let ((pipe (remote-pipe machine OPEN_READ - `("guile" "-c" ,(object->string script))))) - (read-string pipe) - (let ((status (close-pipe pipe))) - (unless (zero? status) - ;; Better be safe than sorry: if we ignore the error here, then FILE - ;; may be GC'd just before we start using it. - (leave (_ "failed to register GC root for '~a' on '~a' (status: ~a)~%") - file (build-machine-name machine) status))))) - -(define (remove-gc-roots machine) - "Remove from MACHINE the GC roots previously installed with -'register-gc-root'." - (define script - `(begin - (use-modules (guix config) (ice-9 ftw) - (srfi srfi-1) (srfi srfi-26)) - - (let ((root-directory (string-append %state-directory - "/gcroots/tmp"))) - (false-if-exception - (delete-file - (string-append root-directory "/" ,%gc-root-file))) - - ;; These ones were created with 'guix build -r' (there can be more - ;; than one in case of multiple-output derivations.) - (let ((roots (filter (cut string-prefix? ,%gc-root-file <>) - (scandir ".")))) - (for-each (lambda (file) - (false-if-exception (delete-file file))) - roots))))) - - (let ((pipe (remote-pipe machine OPEN_READ - `("guile" "-c" ,(object->string script))))) - (read-string pipe) - (close-pipe pipe))) - -(define* (offload drv machine - #:key print-build-trace? (max-silent-time 3600) - build-timeout (log-port (build-log-port))) - "Perform DRV on MACHINE, assuming DRV and its prerequisites are available -there, and write the build log to LOG-PORT. Return the exit status." - (format (current-error-port) "offloading '~a' to '~a'...~%" - (derivation-file-name drv) (build-machine-name machine)) - (format (current-error-port) "@ build-remote ~a ~a~%" - (derivation-file-name drv) (build-machine-name machine)) - - ;; Normally DRV has already been protected from GC when it was transferred. - ;; The '-r' flag below prevents the build result from being GC'd. - (let ((pipe (remote-pipe machine OPEN_READ - `("guix" "build" - "-r" ,%gc-root-file - ,(format #f "--max-silent-time=~a" - max-silent-time) - ,@(if build-timeout - (list (format #f "--timeout=~a" - build-timeout)) - '()) - ,(derivation-file-name drv)) - - ;; Since 'guix build' writes the build log to its - ;; stderr, everything will go directly to LOG-PORT. - #:error-port log-port))) - (let loop ((line (read-line pipe))) - (unless (eof-object? line) - (display line log-port) - (newline log-port) - (loop (read-line pipe)))) - - (close-pipe pipe))) - (define* (transfer-and-offload drv machine #:key (inputs '()) @@ -416,120 +348,131 @@ there, and write the build log to LOG-PORT. Return the exit status." "Offload DRV to MACHINE. Prior to the actual offloading, transfer all of INPUTS to MACHINE; if building DRV succeeds, retrieve all of OUTPUTS from MACHINE." - (when (begin - (register-gc-root (derivation-file-name drv) machine) - (send-files (cons (derivation-file-name drv) inputs) - machine)) - (let ((status (offload drv machine - #:print-build-trace? print-build-trace? - #:max-silent-time max-silent-time - #:build-timeout build-timeout))) - (if (zero? status) - (begin - (retrieve-files outputs machine) - (remove-gc-roots machine) - (format (current-error-port) - "done with offloaded '~a'~%" - (derivation-file-name drv))) - (begin - (remove-gc-roots machine) - (format (current-error-port) - "derivation '~a' offloaded to '~a' failed \ -with exit code ~a~%" - (derivation-file-name drv) - (build-machine-name machine) - (status:exit-val status)) - - ;; Use exit code 100 for a permanent build failure. The daemon - ;; interprets other non-zero codes as transient build failures. - (primitive-exit 100)))))) - -(define (send-files files machine) - "Send the subset of FILES that's missing to MACHINE's store. Return #t on -success, #f otherwise." - (define (missing-files files) - ;; Return the subset of FILES not already on MACHINE. - (let*-values (((files) - (format #f "~{~a~%~}" files)) - ((missing pids) - (filtered-port - (append (list (which %lshg-command) - "-l" (build-machine-user machine) - "-p" (number->string - (build-machine-port machine)) - "-i" (build-machine-private-key machine)) - (build-machine-ssh-options machine) - (cons (build-machine-name machine) - '("guix" "archive" "--missing"))) - (open-input-string files))) - ((result) - (read-string missing))) - (for-each waitpid pids) - (string-tokenize result))) + (define session + (open-ssh-session machine)) + + (define store + (connect-to-remote-daemon session + (build-machine-daemon-socket machine))) + + (set-build-options store + #:print-build-trace print-build-trace? + #:max-silent-time max-silent-time + #:timeout build-timeout) + + ;; Protect DRV from garbage collection. + (add-temp-root store (derivation-file-name drv)) + + (send-files (cons (derivation-file-name drv) inputs) + store) + (format (current-error-port) "offloading '~a' to '~a'...~%" + (derivation-file-name drv) (build-machine-name machine)) + (format (current-error-port) "@ build-remote ~a ~a~%" + (derivation-file-name drv) (build-machine-name machine)) + + (guard (c ((nix-protocol-error? c) + (format (current-error-port) + (_ "derivation '~a' offloaded to '~a' failed: ~a~%") + (derivation-file-name drv) + (build-machine-name machine) + (nix-protocol-error-message c)) + ;; Use exit code 100 for a permanent build failure. The daemon + ;; interprets other non-zero codes as transient build failures. + (primitive-exit 100))) + (build-derivations store (list drv))) + + (retrieve-files outputs store) + (format (current-error-port) "done with offloaded '~a'~%" + (derivation-file-name drv))) + +(define (store-import-channel session) + "Return an output port to which archives to be exported to SESSION's store +can be written." + ;; Using the 'import-paths' RPC on a remote store would be slow because it + ;; makes a round trip every time 32 KiB have been transferred. This + ;; procedure instead opens a separate channel to use the remote + ;; 'import-paths' procedure, which consumes all the data in a single round + ;; trip. + (define import + `(begin + (use-modules (guix)) + + (with-store store + (setvbuf (current-input-port) _IONBF) + (import-paths store (current-input-port))))) + + (open-remote-output-pipe session + (string-join + `("guile" "-c" + ,(object->string + (object->string import)))))) + +(define (store-export-channel session files) + "Return an input port from which an export of FILES from SESSION's store can +be read." + ;; Same as above: this is more efficient than calling 'export-paths' on a + ;; remote store. + (define export + `(begin + (use-modules (guix)) + (with-store store + (setvbuf (current-output-port) _IONBF) + (export-paths store ',files (current-output-port))))) + + (open-remote-input-pipe session + (string-join + `("guile" "-c" + ,(object->string + (object->string export)))))) + +(define (send-files files remote) + "Send the subset of FILES that's missing to REMOTE, a remote store." (with-store store - (guard (c ((nix-protocol-error? c) - (warning (_ "failed to export files for '~a': ~s~%") - (build-machine-name machine) - c) - #f)) - - ;; Compute the subset of FILES missing on MACHINE, and send them in - ;; topologically sorted order so that they can actually be imported. - ;; - ;; To reduce load on the machine that's offloading (since it's typically - ;; already quite busy, see hydra.gnu.org), compress with gzip rather - ;; than xz: For a compression ratio 2 times larger, it is 20 times - ;; faster. - (let* ((files (missing-files (topologically-sorted store files))) - (pipe (remote-pipe machine OPEN_WRITE - '("gzip" "-dc" "|" - "guix" "archive" "--import") - #:quote? #f))) - (format #t (_ "sending ~a store files to '~a'...~%") - (length files) (build-machine-name machine)) - (call-with-compressed-output-port 'gzip pipe - (lambda (compressed) - (catch 'system-error - (lambda () - (export-paths store files compressed)) - (lambda args - (warning (_ "failed while exporting files to '~a': ~a~%") - (build-machine-name machine) - (strerror (system-error-errno args)))))) - #:options '("--fast")) - - ;; Wait for the 'lsh' process to complete. - (zero? (close-pipe pipe)))))) - -(define (retrieve-files files machine) - "Retrieve FILES from MACHINE's store, and import them." - (define host - (build-machine-name machine)) - - (let ((pipe (remote-pipe machine OPEN_READ - `("guix" "archive" "--export" ,@files - "|" "xz" "-c") - #:quote? #f))) - (and pipe - (with-store store - (guard (c ((nix-protocol-error? c) - (warning (_ "failed to import files from '~a': ~s~%") - host c) - #f)) - (format (current-error-port) "retrieving ~a files from '~a'...~%" - (length files) host) - - ;; We cannot use the 'import-paths' RPC here because we already - ;; hold the locks for FILES. - (call-with-decompressed-port 'xz pipe - (lambda (decompressed) - (restore-file-set decompressed - #:log-port (current-error-port) - #:lock? #f))) - - ;; Wait for the 'lsh' process to complete. - (zero? (close-pipe pipe))))))) + ;; Compute the subset of FILES missing on SESSION, and send them in + ;; topologically sorted order so that they can actually be imported. + (let* ((sorted (topologically-sorted store files)) + (session (channel-get-session (nix-server-socket remote))) + (node (make-node session)) + (missing (node-eval node + `(begin + (use-modules (guix) + (srfi srfi-1) (srfi srfi-26)) + + (with-store store + (remove (cut valid-path? store <>) + ',sorted))))) + (port (store-import-channel session))) + (format #t (_ "sending ~a store files to '~a'...~%") + (length missing) (session-get session 'host)) + + (export-paths store missing port) + + ;; Tell the remote process that we're done. (In theory the + ;; end-of-archive mark of 'export-paths' would be enough, but in + ;; practice it's not.) + (channel-send-eof port) + + ;; Wait for completion of the remote process. + (let ((result (zero? (channel-get-exit-status port)))) + (close-port port) + result)))) + +(define (retrieve-files files remote) + "Retrieve FILES from SESSION's store, and import them." + (let* ((session (channel-get-session (nix-server-socket remote))) + (host (session-get session 'host)) + (port (store-export-channel session files))) + (format #t (_ "retrieving ~a files from '~a'...~%") + (length files) host) + + ;; We cannot use the 'import-paths' RPC here because we already + ;; hold the locks for FILES. + (let ((result (restore-file-set port + #:log-port (current-error-port) + #:lock? #f))) + (close-port port) + result))) ;;; @@ -547,13 +490,11 @@ success, #f otherwise." (define (machine-load machine) "Return the load of MACHINE, divided by the number of parallel builds allowed on MACHINE." - (let* ((pipe (remote-pipe machine OPEN_READ `("cat" "/proc/loadavg"))) - (line (read-line pipe)) - (status (close-pipe pipe))) - (unless (eqv? 0 (status:exit-val status)) - (warning (_ "failed to obtain load of '~a': SSH client exited with ~a~%") - (build-machine-name machine) - (status:exit-val status))) + (let* ((session (open-ssh-session machine)) + (pipe (open-remote-pipe* session OPEN_READ + "cat" "/proc/loadavg")) + (line (read-line pipe))) + (close-port pipe) (if (eof-object? line) +inf.0 ;MACHINE does not respond, so assume it is infinitely loaded @@ -675,17 +616,6 @@ defines a total order on machines.)" ;; Not now, all the machines are busy. (display "# postpone\n"))))))) -(define-syntax-rule (with-nar-error-handling body ...) - "Execute BODY with any &nar-error suitably reported to the user." - (guard (c ((nar-error? c) - (let ((file (nar-error-file c))) - (if (condition-has-type? c &message) - (leave (_ "while importing file '~a': ~a~%") - file (gettext (condition-message c))) - (leave (_ "failed to import file '~a'~%") - file))))) - body ...)) - ;;; ;;; Entry point. @@ -716,7 +646,7 @@ defines a total order on machines.)" (cond ((regexp-exec request-line-rx line) => (lambda (match) - (with-nar-error-handling + (with-error-handling (process-request (equal? (match:substring match 1) "1") (match:substring match 2) ; system (call-with-input-file diff --git a/guix/store.scm b/guix/store.scm index 7f54b87db1..689a94c636 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -345,50 +345,58 @@ (message nix-protocol-error-message) (status nix-protocol-error-status)) -(define* (open-connection #:optional (file (%daemon-socket-file)) - #:key (reserve-space? #t) cpu-affinity) - "Connect to the daemon over the Unix-domain socket at FILE. When -RESERVE-SPACE? is true, instruct it to reserve a little bit of extra space on -the file system so that the garbage collector can still operate, should the -disk become full. When CPU-AFFINITY is true, it must be an integer -corresponding to an OS-level CPU number to which the daemon's worker process -for this connection will be pinned. Return a server object." +(define (open-unix-domain-socket file) + "Connect to the Unix-domain socket at FILE and return it. Raise a +'&nix-connection-error' upon error." (let ((s (with-fluids ((%default-port-encoding #f)) ;; This trick allows use of the `scm_c_read' optimization. (socket PF_UNIX SOCK_STREAM 0))) (a (make-socket-address PF_UNIX file))) (catch 'system-error - (cut connect s a) + (lambda () + (connect s a) + s) (lambda args ;; Translate the error to something user-friendly. (let ((errno (system-error-errno args))) (raise (condition (&nix-connection-error (file file) - (errno errno))))))) + (errno errno))))))))) - (write-int %worker-magic-1 s) - (let ((r (read-int s))) +(define* (open-connection #:optional (file (%daemon-socket-file)) + #:key port (reserve-space? #t) cpu-affinity) + "Connect to the daemon over the Unix-domain socket at FILE, or, if PORT is +not #f, use it as the I/O port over which to communicate to a build daemon. + +When RESERVE-SPACE? is true, instruct it to reserve a little bit of extra +space on the file system so that the garbage collector can still operate, +should the disk become full. When CPU-AFFINITY is true, it must be an integer +corresponding to an OS-level CPU number to which the daemon's worker process +for this connection will be pinned. Return a server object." + (let ((port (or port (open-unix-domain-socket file)))) + (write-int %worker-magic-1 port) + (let ((r (read-int port))) (and (eqv? r %worker-magic-2) - (let ((v (read-int s))) + (let ((v (read-int port))) (and (eqv? (protocol-major %protocol-version) (protocol-major v)) (begin - (write-int %protocol-version s) + (write-int %protocol-version port) (when (>= (protocol-minor v) 14) - (write-int (if cpu-affinity 1 0) s) + (write-int (if cpu-affinity 1 0) port) (when cpu-affinity - (write-int cpu-affinity s))) + (write-int cpu-affinity port))) (when (>= (protocol-minor v) 11) - (write-int (if reserve-space? 1 0) s)) - (let ((s (%make-nix-server s - (protocol-major v) - (protocol-minor v) - (make-hash-table 100) - (make-hash-table 100)))) - (let loop ((done? (process-stderr s))) - (or done? (process-stderr s))) - s)))))))) + (write-int (if reserve-space? 1 0) port)) + (let ((conn (%make-nix-server port + (protocol-major v) + (protocol-minor v) + (make-hash-table 100) + (make-hash-table 100)))) + (let loop ((done? (process-stderr conn))) + (or done? (process-stderr conn))) + conn)))))))) (define (close-connection server) "Close the connection to SERVER." diff --git a/m4/guix.m4 b/m4/guix.m4 index 6d8ec2e4e0..6630598416 100644 --- a/m4/guix.m4 +++ b/m4/guix.m4 @@ -171,6 +171,24 @@ AC_DEFUN([GUIX_CHECK_UNBUFFERED_CBIP], [ fi]) ]) +dnl GUIX_CHECK_GUILE_SSH +dnl +dnl Check whether a recent-enough Guile-SSH is available. +AC_DEFUN([GUIX_CHECK_GUILE_SSH], [ + dnl Check whether 'channel-send-eof' (introduced in 0.10.2) is present. + AC_CACHE_CHECK([whether Guile-SSH is available and recent enough], + [guix_cv_have_recent_guile_ssh], + [GUILE_CHECK([retval], + [(and (@ (ssh channel) channel-send-eof) + (@ (ssh popen) open-remote-pipe) + (@ (ssh dist node) node-eval))]) + if test "$retval" = 0; then + guix_cv_have_recent_guile_ssh="yes" + else + guix_cv_have_recent_guile_ssh="no" + fi]) +]) + dnl GUIX_TEST_ROOT_DIRECTORY AC_DEFUN([GUIX_TEST_ROOT_DIRECTORY], [ AC_CACHE_CHECK([for unit test root directory], diff --git a/nix/local.mk b/nix/local.mk index 86ef769549..79667ed49e 100644 --- a/nix/local.mk +++ b/nix/local.mk @@ -183,26 +183,26 @@ endif BUILD_DAEMON_OFFLOAD nodist_libexec_SCRIPTS = \ %D%/scripts/guix-authenticate -# The '.service' file for systemd. +# The '.service' files for systemd. systemdservicedir = $(libdir)/systemd/system -nodist_systemdservice_DATA = etc/guix-daemon.service +nodist_systemdservice_DATA = etc/guix-daemon.service etc/guix-publish.service -etc/guix-daemon.service: etc/guix-daemon.service.in \ +etc/guix-%.service: etc/guix-%.service.in \ $(top_builddir)/config.status $(AM_V_GEN)$(MKDIR_P) "`dirname $@`"; \ $(SED) -e 's|@''bindir''@|$(bindir)|' < \ - "$(srcdir)/etc/guix-daemon.service.in" > "$@.tmp"; \ + "$(srcdir)/$<" > "$@.tmp"; \ mv "$@.tmp" "$@" -# The '.conf' job for Upstart. +# The '.conf' jobs for Upstart. upstartjobdir = $(libdir)/upstart/system -nodist_upstartjob_DATA = etc/guix-daemon.conf +nodist_upstartjob_DATA = etc/guix-daemon.conf etc/guix-publish.conf -etc/guix-daemon.conf: etc/guix-daemon.conf.in \ +etc/guix-%.conf: etc/guix-%.conf.in \ $(top_builddir)/config.status $(AM_V_GEN)$(MKDIR_P) "`dirname $@`"; \ $(SED) -e 's|@''bindir''@|$(bindir)|' < \ - "$(srcdir)/etc/guix-daemon.conf.in" > "$@.tmp"; \ + "$(srcdir)/$<" > "$@.tmp"; \ mv "$@.tmp" "$@" EXTRA_DIST += \ |