aboutsummaryrefslogtreecommitdiff
path: root/gnu/packages/attr.scm
blob: ff0a07aa6708f33dff8dfbd18eefbac5a515853c (about) (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2012, 2013, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Mark H Weaver <mhw@netris.org>
;;;
;;; 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 attr)
  #:use-module (guix licenses)
  #:use-module (gnu packages perl)
  #:use-module (gnu packages gettext)
  #:use-module (guix packages)
  #:use-module (guix download)
  #:use-module (guix build-system gnu))

(define-public attr
  (package
    (name "attr")
    (version "2.4.47")
    (source (origin
              (method url-fetch)
              (uri (string-append "mirror://savannah/attr/attr-"
                                  version ".src.tar.gz"))
              (sha256
               (base32
                "0nd8y0m6awc9ahv0ciiwf8gy54c8d3j51pw9xg7f7cn579jjyxr5"))))
    (build-system gnu-build-system)
    (arguments
     `(#:phases
       (modify-phases %standard-phases
         (add-after 'configure 'patch-makefile-SHELL
           (lambda _
             (patch-makefile-SHELL "include/buildmacros")
             #t))
         (replace 'install
           (lambda _
             (invoke "make"
                     "install"
                     "install-lib"
                     "install-dev")))
         (replace 'check
           (lambda* (#:key target #:allow-other-keys)
             ;; Use the right shell.
             (substitute* "test/run"
               (("/bin/sh")
                (which "sh")))

             ;; When building natively, run the tests.
             ;;
             ;; Note that we use system* and unconditionally return #t here
             ;; to ignore the test result, because the tests will fail when
             ;; the build is performed on a file system without support for
             ;; extended attributes, and we wish to allow Guix to be built
             ;; on such systems.
             (unless target
               (system* "make" "tests" "-C" "test"))
             #t)))))
    (inputs
     ;; Perl is needed to run tests; remove it from cross builds.
     (if (%current-target-system)
         '()
         `(("perl" ,perl))))
    (native-inputs
     `(("gettext" ,gettext-minimal)))

    (home-page "https://savannah.nongnu.org/projects/attr/")
    (synopsis "Library and tools for manipulating extended attributes")
    (description
     "Portable library and tools for manipulating extended attributes.")
    (license (list gpl2+ lgpl2.1+))))
d' style='width: 1.2%;'/> -rw-r--r--gnu/installer/newt/page.scm587
-rw-r--r--gnu/installer/newt/partition.scm8
-rw-r--r--gnu/installer/newt/user.scm64
-rw-r--r--gnu/installer/newt/welcome.scm44
-rw-r--r--gnu/installer/steps.scm25
-rw-r--r--gnu/installer/tests.scm340
-rw-r--r--gnu/installer/utils.scm158
-rw-r--r--gnu/local.mk13
-rw-r--r--gnu/packages/admin.scm4
-rw-r--r--gnu/packages/assembly.scm2
-rw-r--r--gnu/packages/audio.scm61
-rw-r--r--gnu/packages/bioconductor.scm24
-rw-r--r--gnu/packages/bioinformatics.scm90
-rw-r--r--gnu/packages/ccache.scm23
-rw-r--r--gnu/packages/chemistry.scm5
-rw-r--r--gnu/packages/chromium.scm4
-rw-r--r--gnu/packages/compression.scm53
-rw-r--r--gnu/packages/coq.scm3
-rw-r--r--gnu/packages/cpp.scm2
-rw-r--r--gnu/packages/cran.scm139
-rw-r--r--gnu/packages/crates-io.scm4
-rw-r--r--gnu/packages/cups.scm6
-rw-r--r--gnu/packages/databases.scm35
-rw-r--r--gnu/packages/debug.scm71
-rw-r--r--gnu/packages/dictionaries.scm2
-rw-r--r--gnu/packages/dns.scm8
-rw-r--r--gnu/packages/education.scm6
-rw-r--r--gnu/packages/emacs-xyz.scm98
-rw-r--r--gnu/packages/engineering.scm2
-rw-r--r--gnu/packages/finance.scm8
-rw-r--r--gnu/packages/fonts.scm47
-rw-r--r--gnu/packages/fontutils.scm101
-rw-r--r--gnu/packages/freedesktop.scm1
-rw-r--r--gnu/packages/game-development.scm2
-rw-r--r--gnu/packages/games.scm2
-rw-r--r--gnu/packages/geo.scm64
-rw-r--r--gnu/packages/gkrellm.scm7
-rw-r--r--gnu/packages/gnome.scm153
-rw-r--r--gnu/packages/gnuzilla.scm12
-rw-r--r--gnu/packages/golang.scm2
-rw-r--r--gnu/packages/guile-xyz.scm50
-rw-r--r--gnu/packages/guile.scm27
-rw-r--r--gnu/packages/haskell-apps.scm6
-rw-r--r--gnu/packages/idris.scm2
-rw-r--r--gnu/packages/image.scm4
-rw-r--r--gnu/packages/java.scm36
-rw-r--r--gnu/packages/kde-multimedia.scm4
-rw-r--r--gnu/packages/kde-pim.scm55
-rw-r--r--gnu/packages/kde-systemtools.scm12
-rw-r--r--gnu/packages/kerberos.scm2
-rw-r--r--gnu/packages/linux.scm35
-rw-r--r--gnu/packages/lisp-xyz.scm109
-rw-r--r--gnu/packages/machine-learning.scm10
-rw-r--r--gnu/packages/mail.scm12
-rw-r--r--gnu/packages/man.scm4
-rw-r--r--gnu/packages/maths.scm50
-rw-r--r--gnu/packages/messaging.scm2
-rw-r--r--gnu/packages/music.scm60
-rw-r--r--gnu/packages/networking.scm2
-rw-r--r--gnu/packages/ntp.scm8
-rw-r--r--gnu/packages/package-management.scm10
-rw-r--r--gnu/packages/patches/akonadi-Revert-Make-installation-properly-relo.patch (renamed from gnu/packages/patches/akonadi-Revert-Make-installation-properly-relocatabl.patch)0
-rw-r--r--gnu/packages/patches/anki-mpv-args.patch42
-rw-r--r--gnu/packages/patches/csvkit-fix-tests.patch45
-rw-r--r--gnu/packages/patches/guile-3.0-crash.patch17
-rw-r--r--gnu/packages/patches/icecat-makeicecat.patch4
-rw-r--r--gnu/packages/patches/libseccomp-open-aarch64.patch27
-rw-r--r--gnu/packages/patches/qemu-CVE-2020-8608.patch269
-rw-r--r--gnu/packages/patches/sdl-pango-fix-explicit-SDLPango_CopyFTBitmapTo.patch (renamed from gnu/packages/patches/sdl-pango-fix-explicit-SDLPango_CopyFTBitmapToSurface.patch)0
-rw-r--r--gnu/packages/patches/spice-fix-test-armhf.patch19
-rw-r--r--gnu/packages/patches/suitesparse-mongoose-cmake.patch27
-rw-r--r--gnu/packages/patches/woff2-libbrotli.patch84
-rw-r--r--gnu/packages/perl.scm93
-rw-r--r--gnu/packages/plotutils.scm2
-rw-r--r--gnu/packages/pretty-print.scm12
-rw-r--r--gnu/packages/python-web.scm6
-rw-r--r--gnu/packages/python-xyz.scm359
-rw-r--r--gnu/packages/re2c.scm2
-rw-r--r--gnu/packages/rust-apps.scm7
-rw-r--r--gnu/packages/samba.scm88
-rw-r--r--gnu/packages/scheme.scm4
-rw-r--r--gnu/packages/sdl.scm2
-rw-r--r--gnu/packages/shells.scm2
-rw-r--r--gnu/packages/skarnet.scm26
-rw-r--r--gnu/packages/slang.scm2
-rw-r--r--gnu/packages/sphinx.scm26
-rw-r--r--gnu/packages/spice.scm11
-rw-r--r--gnu/packages/statistics.scm39
-rw-r--r--gnu/packages/telephony.scm7
-rw-r--r--gnu/packages/terminals.scm8
-rw-r--r--gnu/packages/toys.scm36
-rw-r--r--gnu/packages/unicode.scm2
-rw-r--r--gnu/packages/version-control.scm41
-rw-r--r--gnu/packages/video.scm4
-rw-r--r--gnu/packages/vim.scm25
-rw-r--r--gnu/packages/virtualization.scm5
-rw-r--r--gnu/packages/web-browsers.scm12
-rw-r--r--gnu/packages/web.scm29
-rw-r--r--gnu/packages/wireservice.scm8
-rw-r--r--gnu/packages/wm.scm2
-rw-r--r--gnu/packages/xdisorg.scm2
-rw-r--r--gnu/packages/xfce.scm24
-rw-r--r--gnu/packages/xml.scm2
-rw-r--r--gnu/services/base.scm6
-rw-r--r--gnu/services/certbot.scm12
-rw-r--r--gnu/services/cuirass.scm13
-rw-r--r--gnu/services/guix.scm15
-rw-r--r--gnu/services/nfs.scm1
-rw-r--r--gnu/system.scm8
-rw-r--r--gnu/system/vm.scm5
-rw-r--r--gnu/tests.scm8
-rw-r--r--gnu/tests/base.scm23
-rw-r--r--gnu/tests/docker.scm4
-rw-r--r--gnu/tests/install.scm204
-rw-r--r--gnu/tests/mail.scm96
-rw-r--r--gnu/tests/monitoring.scm7
-rw-r--r--guix/download.scm1
-rw-r--r--guix/import/cran.scm9
-rw-r--r--guix/scripts.scm2
-rw-r--r--guix/scripts/build.scm24
-rw-r--r--guix/scripts/weather.scm41
-rw-r--r--po/doc/local.mk4
-rw-r--r--tests/guix-build.sh13
137 files changed, 3812 insertions, 1475 deletions
diff --git a/Makefile.am b/Makefile.am
index 5422172e64..f595a54fa9 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -1,5 +1,5 @@
# GNU Guix --- Functional package management for GNU
-# Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
# Copyright © 2013 Andreas Enge <andreas@enge.fr>
# Copyright © 2015, 2017 Alex Kost <alezost@gmail.com>
# Copyright © 2016, 2018 Mathieu Lirzin <mthl@gnu.org>
@@ -511,9 +511,7 @@ endif !CAN_RUN_TESTS
check-system: $(GOBJECTS)
$(AM_V_at)$(top_builddir)/pre-inst-env \
- $(GUILE) --no-auto-compile \
- -e '(@@ (run-system-tests) run-system-tests)' \
- $(top_srcdir)/build-aux/run-system-tests.scm
+ guix build -m $(top_srcdir)/etc/system-tests.scm -K
# Public keys used to sign substitutes.
dist_pkgdata_DATA = \
@@ -544,6 +542,7 @@ EXTRA_DIST += \
scripts/guix.in \
etc/guix-install.sh \
etc/news.scm \
+ etc/system-tests.scm \
build-aux/build-self.scm \
build-aux/compile-all.scm \
build-aux/hydra/evaluate.scm \
@@ -561,7 +560,6 @@ EXTRA_DIST += \
build-aux/test-driver.scm \
build-aux/update-guix-package.scm \
build-aux/update-NEWS.scm \
- build-aux/run-system-tests.scm \
d3.v3.js \
graph.js \
tests/test.drv \
diff --git a/build-aux/git-authenticate.scm b/build-aux/git-authenticate.scm
index 640dedbff5..514d201c80 100644
--- a/build-aux/git-authenticate.scm
+++ b/build-aux/git-authenticate.scm
@@ -169,8 +169,12 @@
"BCA6 89B6 3655 3801 C3C6 2150 197A 5888 235F ACAC")
("rhelling"
"0154 E1B9 1CC9 D9EF 7764 8DE7 F3A7 27DB 44FC CA36")
- ("roelj"
+ ("roelj (old)"
"17CB 2812 EB63 3DFF 2C7F 0452 C3EC 1DCA 8430 72E1")
+ ("roelj"
+ ;; From commit cc51c03ff867d4633505354819c6d88af88bf919 (March 2020).
+ ;; See <https://lists.gnu.org/archive/html/guix-devel/2020-03/msg00070.html>.
+ "F556 FD94 FB8F 8B87 79E3 6832 CBD0 CD51 38C1 9AFC")
("roptat (old)"
"B5FA E628 5B41 3728 B2A0 FAED 4311 1F45 2008 6A0C")
("roptat"
diff --git a/build-aux/hydra/gnu-system.scm b/build-aux/hydra/gnu-system.scm
index f54302cf63..4afdb48903 100644
--- a/build-aux/hydra/gnu-system.scm
+++ b/build-aux/hydra/gnu-system.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2018, 2019 Clément Lassieur <clement@lassieur.org>
;;;
@@ -31,7 +31,7 @@
;; XXX: Debugging hack: since `hydra-eval-guile-jobs' redirects the output
;; port to the bit bucket, let us write to the error port instead.
-(setvbuf (current-error-port) _IOLBF)
+(setvbuf (current-error-port) 'line)
(set-current-output-port (current-error-port))
(define (find-current-checkout arguments)
diff --git a/build-aux/hydra/guix-modular.scm b/build-aux/hydra/guix-modular.scm
index 9ff9e090fc..8e07e7cd01 100644
--- a/build-aux/hydra/guix-modular.scm
+++ b/build-aux/hydra/guix-modular.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2018, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -33,7 +33,7 @@
;; XXX: Debugging hack: since `hydra-eval-guile-jobs' redirects the output
;; port to the bit bucket, let us write to the error port instead.
-(setvbuf (current-error-port) _IOLBF)
+(setvbuf (current-error-port) 'line)
(set-current-output-port (current-error-port))
(define* (build-job store source version system)
diff --git a/build-aux/run-system-tests.scm b/build-aux/run-system-tests.scm
deleted file mode 100644
index b0cb3bd2bf..0000000000
--- a/build-aux/run-system-tests.scm
+++ /dev/null
@@ -1,115 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
-;;;
-;;; 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 (run-system-tests)
- #:use-module (gnu tests)
- #:use-module (gnu packages package-management)
- #:use-module ((gnu ci) #:select (channel-instance->package))
- #:use-module (guix store)
- #:use-module ((guix status) #:select (with-status-verbosity))
- #:use-module (guix monads)
- #:use-module (guix channels)
- #:use-module (guix derivations)
- #:use-module ((guix git-download) #:select (git-predicate))
- #:use-module (guix utils)
- #:use-module (guix ui)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-34)
- #:use-module (ice-9 match)
- #:export (run-system-tests))
-
-(define (built-derivations* drv)
- (lambda (store)
- (guard (c ((store-protocol-error? c)
- (values #f store)))
- (values (build-derivations store drv) store))))
-
-(define (filterm mproc lst) ;XXX: move to (guix monads)
- (with-monad %store-monad
- (>>= (foldm %store-monad
- (lambda (item result)
- (mlet %store-monad ((keep? (mproc item)))
- (return (if keep?
- (cons item result)
- result))))
- '()
- lst)
- (lift1 reverse %store-monad))))
-
-(define (tests-for-channel-instance instance)
- "Return a list of tests for perform, using Guix from INSTANCE, a channel
-instance."
- ;; Honor the 'TESTS' environment variable so that one can select a subset
- ;; of tests to run in the usual way:
- ;;
- ;; make check-system TESTS=installed-os
- (parameterize ((current-guix-package
- (channel-instance->package instance)))
- (match (getenv "TESTS")
- (#f
- (all-system-tests))
- ((= string-tokenize (tests ...))
- (filter (lambda (test)
- (member (system-test-name test) tests))
- (all-system-tests))))))
-
-
-
-(define (run-system-tests . args)
- (define source
- (string-append (current-source-directory) "/.."))
-
- (with-store store
- (with-status-verbosity 2
- (run-with-store store
- ;; Intern SOURCE so that 'build-from-source' in (guix channels) sees
- ;; "fresh" file names and thus doesn't find itself loading .go files
- ;; from ~/.cache/guile when it loads 'build-aux/build-self.scm'.
- ;; XXX: It would be best to not do it upfront because we may need it.
- (mlet* %store-monad ((source (interned-file source "guix-source"
- #:recursive? #t
- #:select?
- (or (git-predicate source)
- (const #t))))
- (instance -> (checkout->channel-instance source))
- (tests -> (tests-for-channel-instance instance))
- (drv (mapm %store-monad system-test-value tests))
- (out -> (map derivation->output-path drv)))
- (format (current-error-port) "Running ~a system tests...~%"
- (length tests))
-
- (mbegin %store-monad
- (show-what-to-build* drv)
- (set-build-options* #:keep-going? #t #:keep-failed? #t
- #:print-build-trace #t
- #:print-extended-build-trace? #t
- #:fallback? #t)
- (built-derivations* drv)
- (mlet %store-monad ((valid (filterm (store-lift valid-path?)
- out))
- (failed (filterm (store-lift
- (negate valid-path?))
- out)))
- (format #t "TOTAL: ~a\n" (length drv))
- (for-each (lambda (item)
- (format #t "PASS: ~a~%" item))
- valid)
- (for-each (lambda (item)
- (format #t "FAIL: ~a~%" item))
- failed)
- (exit (null? failed)))))))))
diff --git a/doc/contributing.texi b/doc/contributing.texi
index 9d45becf86..afcc030b4f 100644
--- a/doc/contributing.texi
+++ b/doc/contributing.texi
@@ -12,7 +12,7 @@ particularly welcome help on packaging (@pxref{Packaging Guidelines}).
We want to provide a warm, friendly, and harassment-free environment, so
that anyone can contribute to the best of their abilities. To this end
our project uses a ``Contributor Covenant'', which was adapted from
-@url{http://contributor-covenant.org/}. You can find a local version in
+@url{https://contributor-covenant.org/}. You can find a local version in
the @file{CODE-OF-CONDUCT} file in the source tree.
Contributors are not required to use their legal name in patches and
@@ -98,12 +98,12 @@ following are the required packages in addition to those mentioned in the
installation instructions (@pxref{Requirements}).
@itemize
-@item @url{http://gnu.org/software/autoconf/, GNU Autoconf};
-@item @url{http://gnu.org/software/automake/, GNU Automake};
-@item @url{http://gnu.org/software/gettext/, GNU Gettext};
-@item @url{http://gnu.org/software/texinfo/, GNU Texinfo};
-@item @url{http://www.graphviz.org/, Graphviz};
-@item @url{http://www.gnu.org/software/help2man/, GNU Help2man (optional)}.
+@item @url{https://gnu.org/software/autoconf/, GNU Autoconf};
+@item @url{https://gnu.org/software/automake/, GNU Automake};
+@item @url{https://gnu.org/software/gettext/, GNU Gettext};
+@item @url{https://gnu.org/software/texinfo/, GNU Texinfo};
+@item @url{https://www.graphviz.org/, Graphviz};
+@item @url{https://www.gnu.org/software/help2man/, GNU Help2man (optional)}.
@end itemize
On Guix, extra dependencies can be added by instead running @command{guix
@@ -217,8 +217,8 @@ you want to upgrade your local source tree.
The Perfect Setup to hack on Guix is basically the perfect setup used
for Guile hacking (@pxref{Using Guile in Emacs,,, guile, Guile Reference
Manual}). First, you need more than an editor, you need
-@url{http://www.gnu.org/software/emacs, Emacs}, empowered by the
-wonderful @url{http://nongnu.org/geiser/, Geiser}. To set that up, run:
+@url{https://www.gnu.org/software/emacs, Emacs}, empowered by the
+wonderful @url{https://nongnu.org/geiser/, Geiser}. To set that up, run:
@example
guix package -i emacs guile emacs-geiser
@@ -250,7 +250,7 @@ s-expression, etc.
@cindex reducing boilerplate
We also provide templates for common git commit messages and package
definitions in the @file{etc/snippets} directory. These templates can
-be used with @url{http://joaotavora.github.io/yasnippet/, YASnippet} to
+be used with @url{https://joaotavora.github.io/yasnippet/, YASnippet} to
expand short trigger strings to interactive text snippets. You may want
to add the snippets directory to the @var{yas-snippet-dirs} variable in
Emacs.
@@ -385,14 +385,14 @@ needed is to review and apply the patch.
@cindex free software
The GNU operating system has been developed so that users can have
freedom in their computing. GNU is @dfn{free software}, meaning that
-users have the @url{http://www.gnu.org/philosophy/free-sw.html,four
+users have the @url{https://www.gnu.org/philosophy/free-sw.html,four
essential freedoms}: to run the program, to study and change the program
in source code form, to redistribute exact copies, and to distribute
modified versions. Packages found in the GNU distribution provide only
software that conveys these four freedoms.
In addition, the GNU distribution follow the
-@url{http://www.gnu.org/distros/free-system-distribution-guidelines.html,free
+@url{https://www.gnu.org/distros/free-system-distribution-guidelines.html,free
software distribution guidelines}. Among other things, these guidelines
reject non-free firmware, recommendations of non-free software, and
discuss ways to deal with trademarks and patents.
@@ -571,7 +571,7 @@ such as @command{guix package --show} take care of rendering it
appropriately.
Synopses and descriptions are translated by volunteers
-@uref{http://translationproject.org/domain/guix-packages.html, at the
+@uref{https://translationproject.org/domain/guix-packages.html, at the
Translation Project} so that as many users as possible can read them in
their native language. User interfaces search them and display them in
the language specified by the current locale.
@@ -838,7 +838,7 @@ especially when matching lists.
@cindex coding style
When writing Scheme code, we follow common wisdom among Scheme
programmers. In general, we follow the
-@url{http://mumble.net/~campbell/scheme/style.txt, Riastradh's Lisp
+@url{https://mumble.net/~campbell/scheme/style.txt, Riastradh's Lisp
Style Rules}. This document happens to describe the conventions mostly
used in Guile’s code too. It is very thoughtful and well written, so
please do read it.
diff --git a/doc/fdl-1.3.texi b/doc/fdl-1.3.texi
index cb71f05a17..11dc812753 100644
--- a/doc/fdl-1.3.texi
+++ b/doc/fdl-1.3.texi
@@ -6,7 +6,7 @@
@display
Copyright @copyright{} 2000, 2001, 2002, 2007, 2008 Free Software Foundation, Inc.
-@uref{http://fsf.org/}
+@uref{https://fsf.org/}
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
@@ -414,7 +414,7 @@ The Free Software Foundation may publish new, revised versions
of the GNU Free Documentation License from time to time. Such new
versions will be similar in spirit to the present version, but may
differ in detail to address new problems or concerns. See
-@uref{http://www.gnu.org/copyleft/}.
+@uref{https://www.gnu.org/copyleft/}.
Each version of the License is given a distinguishing version number.
If the Document specifies that a particular numbered version of this
diff --git a/doc/guix.texi b/doc/guix.texi
index fab9159530..eb6eb99361 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -74,6 +74,7 @@ Copyright @copyright{} 2019, 2020 Simon Tournier@*
Copyright @copyright{} 2020 Wiktor Żelazny@*
Copyright @copyright{} 2020 Damien Cassou@*
Copyright @copyright{} 2020 Jakub Kądziołka@*
+Copyright @copyright{} 2020 Jack Hill@*
Permission is granted to copy, distribute and/or modify this document
under the terms of the GNU Free Documentation License, Version 1.3 or
@@ -6777,7 +6778,7 @@ linux-module-build-system, use the key #:linux to specify it).
@defvr {Scheme Variable} node-build-system
This variable is exported by @code{(guix build-system node)}. It
-implements the build procedure used by @uref{http://nodejs.org,
+implements the build procedure used by @uref{https://nodejs.org,
Node.js}, which implements an approximation of the @code{npm install}
command, followed by an @code{npm test} command.
@@ -13350,7 +13351,7 @@ The ModemManager package to use.
@defvr {Scheme Variable} usb-modeswitch-service-type
This is the service type for the
-@uref{http://www.draisberghof.de/usb_modeswitch/, USB_ModeSwitch} service. The
+@uref{https://www.draisberghof.de/usb_modeswitch/, USB_ModeSwitch} service. The
value for this service type is a @code{usb-modeswitch-configuration} record.
When plugged in, some USB modems (and other USB devices) initially present
@@ -13595,7 +13596,7 @@ The nftables ruleset to use. This may be any ``file-like'' object
@cindex ntpd, service for the Network Time Protocol daemon
@cindex real time clock
@defvr {Scheme Variable} ntp-service-type
-This is the type of the service running the @uref{http://www.ntp.org,
+This is the type of the service running the @uref{https://www.ntp.org,
Network Time Protocol (NTP)} daemon, @command{ntpd}. The daemon will keep the
system clock synchronized with that of the specified NTP servers.
@@ -14233,7 +14234,7 @@ Its value must be a @code{zero-configuration} record---see below.
This service extends the name service cache daemon (nscd) so that it can
resolve @code{.local} host names using
-@uref{http://0pointer.de/lennart/projects/nss-mdns/, nss-mdns}. @xref{Name
+@uref{https://0pointer.de/lennart/projects/nss-mdns/, nss-mdns}. @xref{Name
Service Switch}, for information on host name resolution.
Additionally, add the @var{avahi} package to the system profile so that
@@ -16052,7 +16053,7 @@ Data type representing the configuration for @code{alsa-service}.
@item @code{pulseaudio?} (default: @var{#t})
Whether ALSA applications should transparently be made to use the
-@uref{http://www.pulseaudio.org/, PulseAudio} sound server.
+@uref{https://www.pulseaudio.org/, PulseAudio} sound server.
Using PulseAudio allows you to run several sound-producing applications
at the same time and to individual control them @i{via}
@@ -16100,7 +16101,7 @@ See @uref{https://www.alsa-project.org/main/index.php/Asoundrc} for the
details.
@deffn {Scheme Variable} pulseaudio-service-type
-This is the type for the @uref{http://www.pulseaudio.org/, PulseAudio}
+This is the type for the @uref{https://www.pulseaudio.org/, PulseAudio}
sound server. It exists to allow system overrides of the default settings
via @code{pulseaudio-configuration}, see below.
@@ -20398,7 +20399,7 @@ configuration. Otherwise this must be a file-like object with valid
VCL syntax.
@c Varnish does not support HTTPS, so keep this URL to avoid confusion.
-For example, to mirror @url{http://www.gnu.org,www.gnu.org} with VCL you
+For example, to mirror @url{https://www.gnu.org,www.gnu.org} with VCL you
can do something along these lines:
@lisp
@@ -21008,6 +21009,10 @@ and several @code{domains}.
Mandatory email used for registration, recovery contact, and important
account notifications.
+@item @code{server} (default: @code{#f})
+Optional URL of ACME server. Setting this overrides certbot's default,
+which is the Let's Encrypt server.
+
@item @code{rsa-key-size} (default: @code{2048})
Size of the RSA key.
@@ -22445,6 +22450,9 @@ Only evaluate specifications and build derivations once.
When substituting a pre-built binary fails, fall back to building
packages locally.
+@item @code{extra-options} (default: @code{'()})
+Extra options to pass when running the Cuirass processes.
+
@item @code{cuirass} (default: @code{cuirass})
The Cuirass package to use.
@end table
@@ -25245,6 +25253,12 @@ If set, this is the @code{getmail-retriever-configuration} object with
which to configure getmail to fetch mail from the guix-commits mailing
list.
+@item @code{extra-options} (default: @var{'()})
+Extra command line options for @code{guix-data-service}.
+
+@item @code{extra-process-jobs-options} (default: @var{'()})
+Extra command line options for @code{guix-data-service-process-jobs}.
+
@end table
@end deftp
@@ -25814,7 +25828,7 @@ next method in the list. The NSS configuration is given in the
@cindex nss-mdns
@cindex .local, host name lookup
As an example, the declaration below configures the NSS to use the
-@uref{http://0pointer.de/lennart/projects/nss-mdns/, @code{nss-mdns}
+@uref{https://0pointer.de/lennart/projects/nss-mdns/, @code{nss-mdns}
back-end}, which supports host name lookups over multicast DNS (mDNS)
for host names ending in @code{.local}:
@@ -28286,7 +28300,7 @@ transparency that we get in the rest of the package dependency graph,
where Guix always gives us a source-to-binary mapping. Thus, our goal
is to reduce the set of bootstrap binaries to the bare minimum.
-The @uref{http://bootstrappable.org, Bootstrappable.org web site} lists
+The @uref{https://bootstrappable.org, Bootstrappable.org web site} lists
on-going projects to do that. One of these is about replacing the
bootstrap GCC with a sequence of assemblers, interpreters, and compilers
of increasing complexity, which could be built from source starting from
diff --git a/etc/system-tests.scm b/etc/system-tests.scm
new file mode 100644
index 0000000000..ab2827e70a
--- /dev/null
+++ b/etc/system-tests.scm
@@ -0,0 +1,94 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; 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/>.
+
+(use-modules (gnu tests)
+ (gnu packages package-management)
+ ((gnu ci) #:select (channel-source->package))
+ ((guix git-download) #:select (git-predicate))
+ ((guix utils) #:select (current-source-directory))
+ (git)
+ (ice-9 match))
+
+(define (source-commit directory)
+ "Return the commit of the head of DIRECTORY or #f if it could not be
+determined."
+ (let ((repository #f))
+ (catch 'git-error
+ (lambda ()
+ (set! repository (repository-open directory))
+ (let* ((head (repository-head repository))
+ (target (reference-target head))
+ (commit (oid->string target)))
+ (repository-close! repository)
+ commit))
+ (lambda _
+ (when repository
+ (repository-close! repository))
+ #f))))
+
+(define (tests-for-current-guix source commit)
+ "Return a list of tests for perform, using Guix built from SOURCE, a channel
+instance."
+ ;; Honor the 'TESTS' environment variable so that one can select a subset
+ ;; of tests to run in the usual way:
+ ;;
+ ;; make check-system TESTS=installed-os
+ (parameterize ((current-guix-package
+ (channel-source->package source #:commit commit)))
+ (match (getenv "TESTS")
+ (#f
+ (all-system-tests))
+ ((= string-tokenize (tests ...))
+ (filter (lambda (test)
+ (member (system-test-name test) tests))
+ (all-system-tests))))))
+
+(define (system-test->manifest-entry test)
+ "Return a manifest entry for TEST, a system test."
+ (manifest-entry
+ (name (string-append "test." (system-test-name test)))
+ (version "0")
+ (item test)))
+
+(define (system-test-manifest)
+ "Return a manifest containing all the system tests, or all those selected by
+the 'TESTS' environment variable."
+ (define source
+ (string-append (current-source-directory) "/.."))
+
+ (define commit
+ ;; Fetch the current commit ID so we can potentially build the same
+ ;; derivation as ci.guix.gnu.org.
+ (source-commit source))
+
+ ;; Intern SOURCE so that 'build-from-source' in (guix channels) sees
+ ;; "fresh" file names and thus doesn't find itself loading .go files
+ ;; from ~/.cache/guile when it loads 'build-aux/build-self.scm'.
+ (let* ((source (local-file source "guix-source"
+ #:recursive? #t
+ #:select?
+ (or (git-predicate source)
+ (const #t))))
+ (tests (tests-for-current-guix source commit)))
+ (format (current-error-port) "Selected ~a system tests...~%"
+ (length tests))
+
+ (manifest (map system-test->manifest-entry tests))))
+
+;; Return the manifest.
+(system-test-manifest)
diff --git a/gnu/ci.scm b/gnu/ci.scm
index 33c2e84b27..70e86b993e 100644
--- a/gnu/ci.scm
+++ b/gnu/ci.scm
@@ -28,6 +28,7 @@
#:use-module (guix derivations)
#:use-module (guix build-system)
#:use-module (guix monads)
+ #:use-module (guix gexp)
#:use-module (guix ui)
#:use-module ((guix licenses)
#:select (gpl3+ license? license-name))
@@ -54,7 +55,7 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
- #:export (channel-instance->package
+ #:export (channel-source->package
hydra-jobs))
;;; Commentary:
@@ -139,6 +140,49 @@ SYSTEM."
"i686-w64-mingw32"
"x86_64-w64-mingw32"))
+(define (cross-jobs store system)
+ "Return a list of cross-compilation jobs for SYSTEM."
+ (define (from-32-to-64? target)
+ ;; Return true if SYSTEM is 32-bit and TARGET is 64-bit. This hack
+ ;; prevents known-to-fail cross-builds from i686-linux or armhf-linux to
+ ;; mips64el-linux-gnuabi64.
+ (and (or (string-prefix? "i686-" system)
+ (string-prefix? "i586-" system)
+ (string-prefix? "armhf-" system))
+ (string-contains target "64"))) ;x86_64, mips64el, aarch64, etc.
+
+ (define (same? target)
+ ;; Return true if SYSTEM and TARGET are the same thing. This is so we
+ ;; don't try to cross-compile to 'mips64el-linux-gnu' from
+ ;; 'mips64el-linux'.
+ (or (string-contains target system)
+ (and (string-prefix? "armhf" system) ;armhf-linux
+ (string-prefix? "arm" target)))) ;arm-linux-gnueabihf
+
+ (define (pointless? target)
+ ;; Return #t if it makes no sense to cross-build to TARGET from SYSTEM.
+ (match system
+ ((or "x86_64-linux" "i686-linux")
+ (if (string-contains target "mingw")
+ (not (string=? "x86_64-linux" system))
+ #f))
+ (_
+ ;; Don't try to cross-compile from non-Intel platforms: this isn't
+ ;; very useful and these are often brittle configurations.
+ #t)))
+
+ (define (either proc1 proc2 proc3)
+ (lambda (x)
+ (or (proc1 x) (proc2 x) (proc3 x))))
+
+ (append-map (lambda (target)
+ (map (lambda (package)
+ (package-cross-job store (job-name package)
+ package target system))
+ (packages-to-cross-build target)))
+ (remove (either from-32-to-64? same? pointless?)
+ %cross-targets)))
+
(define %guixsd-supported-systems
'("x86_64-linux" "i686-linux" "armhf-linux"))
@@ -200,29 +244,39 @@ system.")
(define channel-build-system
;; Build system used to "convert" a channel instance to a package.
(let* ((build (lambda* (store name inputs
- #:key instance system
+ #:key source commit system
#:allow-other-keys)
(run-with-store store
- (channel-instances->derivation (list instance))
+ ;; SOURCE can be a lowerable object such as <local-file>
+ ;; or a file name. Adjust accordingly.
+ (mlet* %store-monad ((source (if (string? source)
+ (return source)
+ (lower-object source)))
+ (instance
+ -> (checkout->channel-instance
+ source #:commit commit)))
+ (channel-instances->derivation (list instance)))
#:system system)))
- (lower (lambda* (name #:key system instance #:allow-other-keys)
+ (lower (lambda* (name #:key system source commit
+ #:allow-other-keys)
(bag
(name name)
(system system)
(build build)
- (arguments `(#:instance ,instance))))))
+ (arguments `(#:source ,source
+ #:commit ,commit))))))
(build-system (name 'channel)
(description "Turn a channel instance into a package.")
(lower lower))))
-(define (channel-instance->package instance)
- "Return a package for the given channel INSTANCE."
+(define* (channel-source->package source #:key commit)
+ "Return a package for the given channel SOURCE, a lowerable object."
(package
(inherit guix)
- (version (or (string-take (channel-instance-commit instance) 7)
- (string-append (package-version guix) "+")))
+ (version (string-append (package-version guix) "+"))
(build-system channel-build-system)
- (arguments `(#:instance ,instance))
+ (arguments `(#:source ,source
+ #:commit ,commit))
(inputs '())
(native-inputs '())
(propagated-inputs '())))
@@ -230,9 +284,6 @@ system.")
(define* (system-test-jobs store system
#:key source commit)
"Return a list of jobs for the system tests."
- (define instance
- (checkout->channel-instance source #:commit commit))
-
(define (test->thunk test)
(lambda ()
(define drv
@@ -269,7 +320,7 @@ system.")
;; expensive. It also makes sure we get a valid Guix package when this
;; code is not running from a checkout.
(parameterize ((current-guix-package
- (channel-instance->package instance)))
+ (channel-source->package source #:commit commit)))
(map ->job (all-system-tests)))
'()))
@@ -421,48 +472,6 @@ Return #f if no such checkout is found."
(define source
(assq-ref checkout 'file-name))
- (define (cross-jobs system)
- (define (from-32-to-64? target)
- ;; Return true if SYSTEM is 32-bit and TARGET is 64-bit. This hack
- ;; prevents known-to-fail cross-builds from i686-linux or armhf-linux to
- ;; mips64el-linux-gnuabi64.
- (and (or (string-prefix? "i686-" system)
- (string-prefix? "i586-" system)
- (string-prefix? "armhf-" system))
- (string-contains target "64"))) ;x86_64, mips64el, aarch64, etc.
-
- (define (same? target)
- ;; Return true if SYSTEM and TARGET are the same thing. This is so we
- ;; don't try to cross-compile to 'mips64el-linux-gnu' from
- ;; 'mips64el-linux'.
- (or (string-contains target system)
- (and (string-prefix? "armhf" system) ;armhf-linux
- (string-prefix? "arm" target)))) ;arm-linux-gnueabihf
-
- (define (pointless? target)
- ;; Return #t if it makes no sense to cross-build to TARGET from SYSTEM.
- (match system
- ((or "x86_64-linux" "i686-linux")
- (if (string-contains target "mingw")
- (not (string=? "x86_64-linux" system))
- #f))
- (_
- ;; Don't try to cross-compile from non-Intel platforms: this isn't
- ;; very useful and these are often brittle configurations.
- #t)))
-
- (define (either proc1 proc2 proc3)
- (lambda (x)
- (or (proc1 x) (proc2 x) (proc3 x))))
-
- (append-map (lambda (target)
- (map (lambda (package)
- (package-cross-job store (job-name package)
- package target system))
- (packages-to-cross-build target)))
- (remove (either from-32-to-64? same? pointless?)
- %cross-targets)))
-
;; Turn off grafts. Grafting is meant to happen on the user's machines.
(parameterize ((%graft? #f))
;; Return one job for each package, except bootstrap packages.
@@ -487,14 +496,14 @@ Return #f if no such checkout is found."
#:source source
#:commit commit)
(tarball-jobs store system)
- (cross-jobs system))))
+ (cross-jobs store system))))
((core)
;; Build core packages only.
(append (map (lambda (package)
(package-job store (job-name package)
package system))
%core-packages)
- (cross-jobs system)))
+ (cross-jobs store system)))
((hello)
;; Build hello package only.
(if (string=? system (%current-system))
diff --git a/gnu/installer.scm b/gnu/installer.scm
index 04f3dd5f26..e195d4f84b 100644
--- a/gnu/installer.scm
+++ b/gnu/installer.scm
@@ -26,6 +26,8 @@
#:use-module (guix utils)
#:use-module (guix ui)
#:use-module ((guix self) #:select (make-config.scm))
+ #:use-module (guix packages)
+ #:use-module (guix git-download)
#:use-module (gnu installer utils)
#:use-module (gnu packages admin)
#:use-module (gnu packages base)
@@ -280,6 +282,25 @@ selected keymap."
((installer-final-page current-installer)
result prev-steps))))))))
+(define guile-newt
+ ;; Guile-Newt with 'form-watch-fd'.
+ ;; TODO: Remove once a new release is out.
+ (let ((commit "b3c885d42cfac327d3531c9d064939514ce6bf12")
+ (revision "1"))
+ (package
+ (inherit (@ (gnu packages guile-xyz) guile-newt))
+ (name "guile-newt")
+ (version (git-version "0.0.1" revision commit))
+ (source (origin
+ (method git-fetch)
+ (uri (git-reference
+ (url "https://gitlab.com/mothacehe/guile-newt")
+ (commit commit)))
+ (file-name (git-file-name name version))
+ (sha256
+ (base32
+ "02p0bi6c05699idgx6gfkljhqgi8zf09clhzx81i8wa064s70r1y")))))))
+
(define (installer-program)
"Return a file-like object that runs the given INSTALLER."
(define init-gettext
diff --git a/gnu/installer/final.scm b/gnu/installer/final.scm
index 8c2185e36f..3c170e5d0f 100644
--- a/gnu/installer/final.scm
+++ b/gnu/installer/final.scm
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
-;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -28,6 +28,12 @@
#:use-module (gnu build accounts)
#:use-module ((gnu system shadow) #:prefix sys:)
#:use-module (rnrs io ports)
+ #:use-module (srfi srfi-1)
+ #:use-module (ice-9 ftw)
+ #:use-module (ice-9 popen)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 rdelim)
#:export (install-system))
(define %seed
@@ -97,24 +103,92 @@ USERS."
(write-passwd password (string-append etc "/passwd"))
(write-shadow shadow (string-append etc "/shadow")))
+(define* (kill-cow-users cow-path #:key (spare '("udevd")))
+ "Kill all processes that have references to the given COW-PATH in their
+'maps' file. The process whose names are in SPARE list are spared."
+ (define %not-nul
+ (char-set-complement (char-set #\nul)))
+
+ (let ((pids
+ (filter-map (lambda (pid)
+ (call-with-input-file
+ (string-append "/proc/" pid "/maps")
+ (lambda (port)
+ (and (string-contains (get-string-all port)
+ cow-path)
+ (string->number pid)))))
+ (scandir "/proc" string->number))))
+ (for-each (lambda (pid)
+ ;; cmdline does not always exist.
+ (false-if-exception
+ (call-with-input-file
+ (string-append "/proc/" (number->string pid) "/cmdline")
+ (lambda (port)
+ (match (string-tokenize (read-string port) %not-nul)
+ ((argv0 _ ...)
+ (unless (member (pk (basename argv0)) spare)
+ (syslog "Killing process ~a~%" pid)
+ (kill pid SIGKILL)))
+ (_ #f))))))
+ pids)))
+
(define (umount-cow-store)
"Remove the store overlay and the bind-mount on /tmp created by the
-cow-store service."
- (let ((tmp-dir "/remove"))
- (mkdir-p tmp-dir)
- (mount (%store-directory) tmp-dir "" MS_MOVE)
- (umount tmp-dir)
- (umount "/tmp")))
+cow-store service. This procedure is very fragile and a better approach would
+be much appreciated."
+
+ ;; Remove when integrated in (gnu services herd).
+ (define (restart-service name)
+ (with-shepherd-action name ('restart) result
+ result))
+
+ (catch #t
+ (lambda ()
+ (let ((tmp-dir "/remove"))
+ (mkdir-p tmp-dir)
+ (mount (%store-directory) tmp-dir "" MS_MOVE)
+
+ ;; The guix-daemon has possibly opened files from the cow-store,
+ ;; restart it.
+ (restart-service 'guix-daemon)
+
+ ;; Kill all processes started while the cow-store was active (logins
+ ;; on other TTYs for instance).
+ (kill-cow-users tmp-dir)
+
+ ;; Try to umount the store overlay. Some process such as udevd
+ ;; workers might still be active, so do some retries.
+ (let loop ((try 5))
+ (sleep 1)
+ (let ((umounted? (false-if-exception (umount tmp-dir))))
+ (if (and (not umounted?) (> try 0))
+ (loop (- try 1))
+ (if umounted?
+ (syslog "Umounted ~a successfully.~%" tmp-dir)
+ (syslog "Failed to umount ~a.~%" tmp-dir)))))
+
+ (umount "/tmp")))
+ (lambda args
+ (syslog "~a~%" args))))
(define* (install-system locale #:key (users '()))
"Create /etc/shadow and /etc/passwd on the installation target for USERS.
Start COW-STORE service on target directory and launch guix install command in
a subshell. LOCALE must be the locale name under which that command will run,
or #f. Return #t on success and #f on failure."
- (let ((install-command
- (format #f "guix system init --fallback ~a ~a"
- (%installer-configuration-file)
- (%installer-target-dir))))
+ (let* ((options (catch 'system-error
+ (lambda ()
+ ;; If this file exists, it can provide
+ ;; additional command-line options.
+ (call-with-input-file
+ "/tmp/installer-system-init-options"
+ read))
+ (const '())))
+ (install-command (append (list "guix" "system" "init"
+ "--fallback")
+ options
+ (list (%installer-configuration-file)
+ (%installer-target-dir)))))
(mkdir-p (%installer-target-dir))
;; We want to initialize user passwords but we don't want to store them in
@@ -128,7 +202,7 @@ or #f. Return #t on success and #f on failure."
(lambda ()
(start-service 'cow-store (list (%installer-target-dir))))
(lambda ()
- (run-shell-command install-command #:locale locale))
+ (run-command install-command #:locale locale))
(lambda ()
(stop-service 'cow-store)
;; Remove the store overlay created at cow-store service start.
diff --git a/gnu/installer/newt/final.scm b/gnu/installer/newt/final.scm
index 405eee2540..5cb4f6816d 100644
--- a/gnu/installer/newt/final.scm
+++ b/gnu/installer/newt/final.scm
@@ -63,28 +63,38 @@ This will take a few minutes.")
(&installer-step-abort)))))))
(define (run-install-success-page)
- (message-window
- (G_ "Installation complete")
- (G_ "Reboot")
- (G_ "Congratulations! Installation is now complete. \
+ (match (current-clients)
+ (()
+ (message-window
+ (G_ "Installation complete")
+ (G_ "Reboot")
+ (G_ "Congratulations! Installation is now complete. \
You may remove the device containing the installation image and \
-press the button to reboot."))
+press the button to reboot.")))
+ (_
+ ;; When there are clients connected, send them a message and keep going.
+ (send-to-clients '(installation-complete))))
;; Return success so that the installer happily reboots.
'success)
(define (run-install-failed-page)
- (match (choice-window
- (G_ "Installation failed")
- (G_ "Resume")
- (G_ "Restart the installer")
- (G_ "The final system installation step failed. You can resume from \
+ (match (current-clients)
+ (()
+ (match (choice-window
+ (G_ "Installation failed")
+ (G_ "Resume")
+ (G_ "Restart the installer")
+ (G_ "The final system installation step failed. You can resume from \
a specific step, or restart the installer."))
- (1 (raise
- (condition
- (&installer-step-abort))))
- (2
- ;; Keep going, the installer will be restarted later on.
+ (1 (raise
+ (condition
+ (&installer-step-abort))))
+ (2
+ ;; Keep going, the installer will be restarted later on.
+ #t)))
+ (_
+ (send-to-clients '(installation-failure))
#t)))
(define* (run-install-shell locale
diff --git a/gnu/installer/newt/network.scm b/gnu/installer/newt/network.scm
index 40d85817b6..461d5d99c0 100644
--- a/gnu/installer/newt/network.scm
+++ b/gnu/installer/newt/network.scm
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
-;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -119,6 +119,10 @@ network devices were found. Do you want to continue anyway?"))
(define (wait-service-online)
"Display a newt scale until connman detects an Internet access. Do
FULL-VALUE tentatives, spaced by 1 second."
+ (define (online?)
+ (or (connman-online?)
+ (file-exists? "/tmp/installer-assume-online")))
+
(let* ((full-value 5))
(run-scale-page
#:title (G_ "Checking connectivity")
@@ -127,10 +131,10 @@ FULL-VALUE tentatives, spaced by 1 second."
#:scale-update-proc
(lambda (value)
(sleep 1)
- (if (connman-online?)
+ (if (online?)
full-value
(+ value 1))))
- (unless (connman-online?)
+ (unless (online?)
(run-error-page
(G_ "The selected network does not provide access to the \
Internet, please try again.")
diff --git a/gnu/installer/newt/page.scm b/gnu/installer/newt/page.scm
index 8aea5a1109..9031c7d4ba 100644
--- a/gnu/installer/newt/page.scm
+++ b/gnu/installer/newt/page.scm
@@ -19,6 +19,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu installer newt page)
+ #:use-module (gnu installer steps)
#:use-module (gnu installer utils)
#:use-module (gnu installer newt utils)
#:use-module (guix i18n)
@@ -26,7 +27,10 @@
#:use-module (ice-9 match)
#:use-module (ice-9 receive)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
#:use-module (newt)
#:export (draw-info-page
draw-connecting-page
@@ -36,7 +40,9 @@
run-listbox-selection-page
run-scale-page
run-checkbox-tree-page
- run-file-textbox-page))
+ run-file-textbox-page
+
+ run-form-with-clients))
;;; Commentary:
;;;
@@ -49,9 +55,123 @@
;;;
;;; Code:
+(define* (watch-clients! form #:optional (clients (current-clients)))
+ "Have FORM watch the file descriptors corresponding to current client
+connections. Consequently, FORM may exit with the 'exit-fd-ready' reason."
+ (when (current-server-socket)
+ (form-watch-fd form (fileno (current-server-socket))
+ FD-READ))
+
+ (for-each (lambda (client)
+ (form-watch-fd form (fileno client)
+ (logior FD-READ FD-EXCEPT)))
+ clients))
+
+(define close-port-and-reuse-fd
+ (let ((bit-bucket #f))
+ (lambda (port)
+ "Close PORT and redirect its underlying FD to point to a valid open file
+descriptor."
+ (let ((fd (fileno port)))
+ (unless bit-bucket
+ (set! bit-bucket (car (pipe))))
+ (close-port port)
+
+ ;; FIXME: We're leaking FD.
+ (dup2 (fileno bit-bucket) fd)))))
+
+(define* (run-form-with-clients form exp)
+ "Run FORM such as it watches the file descriptors beneath CLIENTS after
+sending EXP to all the clients.
+
+Automatically restart the form when it exits with 'exit-fd-ready but without
+an actual client reply--e.g., it got a connection request or a client
+disconnect.
+
+Like 'run-form', return two values: the exit reason, and an \"argument\"."
+ (define* (discard-client! port #:optional errno)
+ (if errno
+ (syslog "removing client ~d due to ~s~%"
+ (fileno port) (strerror errno))
+ (syslog "removing client ~d due to EOF~%"
+ (fileno port)))
+
+ ;; XXX: Watch out! There's no 'form-unwatch-fd' procedure in Newt so we
+ ;; cheat: we keep PORT's file descriptor open, but make it a duplicate of
+ ;; a valid but inactive FD. Failing to do that, 'run-form' would
+ ;; select(2) on the now-closed port and keep spinning as select(2) returns
+ ;; EBADF.
+ (close-port-and-reuse-fd port)
+
+ (current-clients (delq port (current-clients)))
+ (close-port port))
+
+ (define title
+ ;; Title of FORM.
+ (match exp
+ (((? symbol? tag) alist ...)
+ (match (assq 'title alist)
+ ((_ title) title)
+ (_ tag)))
+ (((? symbol? tag) _ ...)
+ tag)
+ (_
+ 'unknown)))
+
+ ;; Send EXP to all the currently-connected clients.
+ (send-to-clients exp)
+
+ (let loop ()
+ (syslog "running form ~s (~s) with ~d clients~%"
+ form title (length (current-clients)))
+
+ ;; Call 'watch-clients!' within the loop because there might be new
+ ;; clients.
+ (watch-clients! form)
+
+ (let-values (((reason argument) (run-form form)))
+ (match reason
+ ('exit-fd-ready
+ (match (fdes->ports argument)
+ ((port _ ...)
+ (if (memq port (current-clients))
+
+ ;; Read a reply from a client or handle its departure.
+ (catch 'system-error
+ (lambda ()
+ (match (read port)
+ ((? eof-object? eof)
+ (discard-client! port)
+ (loop))
+ (obj
+ (syslog "form ~s (~s): client ~d replied ~s~%"
+ form title (fileno port) obj)
+ (values 'exit-fd-ready obj))))
+ (lambda args
+ (discard-client! port (system-error-errno args))
+ (loop)))
+
+ ;; Accept a new client and send it EXP.
+ (match (accept port)
+ ((client . _)
+ (syslog "accepting new client ~d while on form ~s~%"
+ (fileno client) form)
+ (catch 'system-error
+ (lambda ()
+ (write exp client)
+ (newline client)
+ (force-output client)
+ (current-clients (cons client (current-clients))))
+ (lambda _
+ (close-port client)))
+ (loop)))))))
+ (_
+ (values reason argument))))))
+
(define (draw-info-page text title)
"Draw an informative page with the given TEXT as content. Set the title of
this page to TITLE."
+ (send-to-clients `(info (title ,title) (text ,text)))
(let* ((text-box
(make-reflowed-textbox -1 -1 text 40
#:flags FLAG-BORDER))
@@ -126,20 +246,25 @@ input box, such as FLAG-PASSWORD."
(G_ "Empty input")))))
(let loop ()
(receive (exit-reason argument)
- (run-form form)
- (let ((input (entry-value input-entry)))
- (if (and (not allow-empty-input?)
- (eq? exit-reason 'exit-component)
- (string=? input ""))
- (begin
- ;; Display the error page.
- (error-page)
- ;; Set the focus back to the input input field.
- (set-current-component form input-entry)
- (loop))
- (begin
- (destroy-form-and-pop form)
- input))))))))
+ (run-form-with-clients form
+ `(input (title ,title) (text ,text)
+ (default ,default-text)))
+ (let ((input (if (eq? exit-reason 'exit-fd-ready)
+ argument
+ (entry-value input-entry))))
+ (cond ((not input) ;client disconnect or something
+ (loop))
+ ((and (not allow-empty-input?)
+ (eq? exit-reason 'exit-component)
+ (string=? input ""))
+ ;; Display the error page.
+ (error-page)
+ ;; Set the focus back to the input input field.
+ (set-current-component form input-entry)
+ (loop))
+ (else
+ (destroy-form-and-pop form)
+ input))))))))
(define (run-error-page text title)
"Run a page to inform the user of an error. The page contains the given TEXT
@@ -160,7 +285,8 @@ of the page is set to TITLE."
(newt-set-color COLORSET-ROOT "white" "red")
(add-components-to-form form text-box ok-button)
(make-wrapped-grid-window grid title)
- (run-form form)
+ (run-form-with-clients form
+ `(error (title ,title) (text ,text)))
;; Restore the background to its original color.
(newt-set-color COLORSET-ROOT "white" "blue")
(destroy-form-and-pop form)))
@@ -187,17 +313,23 @@ of the page is set to TITLE."
(make-wrapped-grid-window grid title)
(receive (exit-reason argument)
- (run-form form)
+ (run-form-with-clients form
+ `(confirmation (title ,title)
+ (text ,text)))
(dynamic-wind
(const #t)
(lambda ()
- (case exit-reason
- ((exit-component)
+ (match exit-reason
+ ('exit-component
(cond
((components=? argument ok-button)
#t)
((components=? argument exit-button)
- (exit-button-procedure))))))
+ (exit-button-procedure))))
+ ('exit-fd-ready
+ (if argument
+ #t
+ (exit-button-procedure)))))
(lambda ()
(destroy-form-and-pop form))))))
@@ -222,6 +354,8 @@ of the page is set to TITLE."
(const #t))
(listbox-callback-procedure
identity)
+ (client-callback-procedure
+ listbox-callback-procedure)
(hotkey-callback-procedure
(const #t)))
"Run a page asking the user to select an item in a listbox. The page
@@ -254,9 +388,9 @@ Each time the listbox current item changes, call SKIP-ITEM-PROCEDURE? with the
current listbox item as argument. If it returns #t, skip the element and jump
to the next/previous one depending on the previous item, otherwise do
nothing."
-
- (define (fill-listbox listbox items)
- "Append the given ITEMS to LISTBOX, once they have been converted to text
+ (let loop ()
+ (define (fill-listbox listbox items)
+ "Append the given ITEMS to LISTBOX, once they have been converted to text
with LISTBOX-ITEM->TEXT. Each item appended to the LISTBOX is given a key by
newt. Save this key by returning an association list under the form:
@@ -264,144 +398,165 @@ newt. Save this key by returning an association list under the form:
where NEWT-LISTBOX-KEY is the key returned by APPEND-ENTRY-TO-LISTBOX, when
ITEM was inserted into LISTBOX."
- (map (lambda (item)
- (let* ((text (listbox-item->text item))
- (key (append-entry-to-listbox listbox text)))
- (cons key item)))
- items))
-
- (define (sort-listbox-items listbox-items)
- "Return LISTBOX-ITEMS sorted using the 'string-locale<?' procedure on the text
+ (map (lambda (item)
+ (let* ((text (listbox-item->text item))
+ (key (append-entry-to-listbox listbox text)))
+ (cons key item)))
+ items))
+
+ (define (sort-listbox-items listbox-items)
+ "Return LISTBOX-ITEMS sorted using the 'string-locale<?' procedure on the text
corresponding to each item in the list."
- (let* ((items (map (lambda (item)
- (cons item (listbox-item->text item)))
- listbox-items))
- (sorted-items
- (sort items (lambda (a b)
- (let ((text-a (cdr a))
- (text-b (cdr b)))
- (string-locale<? text-a text-b))))))
- (map car sorted-items)))
-
- ;; Store the last selected listbox item's key.
- (define last-listbox-key (make-parameter #f))
-
- (define (previous-key keys key)
- (let ((index (list-index (cut eq? key <>) keys)))
- (and index
- (> index 0)
- (list-ref keys (- index 1)))))
-
- (define (next-key keys key)
- (let ((index (list-index (cut eq? key <>) keys)))
- (and index
- (< index (- (length keys) 1))
- (list-ref keys (+ index 1)))))
-
- (define (set-default-item listbox listbox-keys default-item)
- "Set the default item of LISTBOX to DEFAULT-ITEM. LISTBOX-KEYS is the
+ (let* ((items (map (lambda (item)
+ (cons item (listbox-item->text item)))
+ listbox-items))
+ (sorted-items
+ (sort items (lambda (a b)
+ (let ((text-a (cdr a))
+ (text-b (cdr b)))
+ (string-locale<? text-a text-b))))))
+ (map car sorted-items)))
+
+ ;; Store the last selected listbox item's key.
+ (define last-listbox-key (make-parameter #f))
+
+ (define (previous-key keys key)
+ (let ((index (list-index (cut eq? key <>) keys)))
+ (and index
+ (> index 0)
+ (list-ref keys (- index 1)))))
+
+ (define (next-key keys key)
+ (let ((index (list-index (cut eq? key <>) keys)))
+ (and index
+ (< index (- (length keys) 1))
+ (list-ref keys (+ index 1)))))
+
+ (define (set-default-item listbox listbox-keys default-item)
+ "Set the default item of LISTBOX to DEFAULT-ITEM. LISTBOX-KEYS is the
association list returned by the FILL-LISTBOX procedure. It is used because
the current listbox item has to be selected by key."
- (for-each (match-lambda
- ((key . item)
- (when (equal? item default-item)
- (set-current-listbox-entry-by-key listbox key))))
- listbox-keys))
-
- (let* ((listbox (make-listbox
- -1 -1
- listbox-height
- (logior FLAG-SCROLL FLAG-BORDER FLAG-RETURNEXIT
- (if listbox-allow-multiple?
- FLAG-MULTIPLE
- 0))))
- (form (make-form #:flags FLAG-NOF12))
- (info-textbox
- (make-reflowed-textbox -1 -1 info-text
- info-textbox-width
- #:flags FLAG-BORDER))
- (button (make-button -1 -1 button-text))
- (button2 (and button2-text
- (make-button -1 -1 button2-text)))
- (grid (vertically-stacked-grid
- GRID-ELEMENT-COMPONENT info-textbox
- GRID-ELEMENT-COMPONENT listbox
- GRID-ELEMENT-SUBGRID
- (apply
- horizontal-stacked-grid
- GRID-ELEMENT-COMPONENT button
- `(,@(if button2
- (list GRID-ELEMENT-COMPONENT button2)
- '())))))
- (sorted-items (if sort-listbox-items?
- (sort-listbox-items listbox-items)
- listbox-items))
- (keys (fill-listbox listbox sorted-items)))
-
- ;; On every listbox element change, check if we need to skip it. If yes,
- ;; depending on the 'last-listbox-key', jump forward or backward. If no,
- ;; do nothing.
- (add-component-callback
- listbox
- (lambda (component)
- (let* ((current-key (current-listbox-entry listbox))
- (listbox-keys (map car keys))
- (last-key (last-listbox-key))
- (item (assoc-ref keys current-key))
- (prev-key (previous-key listbox-keys current-key))
- (next-key (next-key listbox-keys current-key)))
- ;; Update last-listbox-key before a potential call to
- ;; set-current-listbox-entry-by-key, because it will immediately
- ;; cause this callback to be called for the new entry.
- (last-listbox-key current-key)
- (when (skip-item-procedure? item)
- (when (eq? prev-key last-key)
- (if next-key
- (set-current-listbox-entry-by-key listbox next-key)
- (set-current-listbox-entry-by-key listbox prev-key)))
- (when (eq? next-key last-key)
- (if prev-key
- (set-current-listbox-entry-by-key listbox prev-key)
- (set-current-listbox-entry-by-key listbox next-key)))))))
-
- (when listbox-default-item
- (set-default-item listbox keys listbox-default-item))
-
- (when allow-delete?
- (form-add-hotkey form KEY-DELETE))
+ (for-each (match-lambda
+ ((key . item)
+ (when (equal? item default-item)
+ (set-current-listbox-entry-by-key listbox key))))
+ listbox-keys))
+
+ (let* ((listbox (make-listbox
+ -1 -1
+ listbox-height
+ (logior FLAG-SCROLL FLAG-BORDER FLAG-RETURNEXIT
+ (if listbox-allow-multiple?
+ FLAG-MULTIPLE
+ 0))))
+ (form (make-form #:flags FLAG-NOF12))
+ (info-textbox
+ (make-reflowed-textbox -1 -1 info-text
+ info-textbox-width
+ #:flags FLAG-BORDER))
+ (button (make-button -1 -1 button-text))
+ (button2 (and button2-text
+ (make-button -1 -1 button2-text)))
+ (grid (vertically-stacked-grid
+ GRID-ELEMENT-COMPONENT info-textbox
+ GRID-ELEMENT-COMPONENT listbox
+ GRID-ELEMENT-SUBGRID
+ (apply
+ horizontal-stacked-grid
+ GRID-ELEMENT-COMPONENT button
+ `(,@(if button2
+ (list GRID-ELEMENT-COMPONENT button2)
+ '())))))
+ (sorted-items (if sort-listbox-items?
+ (sort-listbox-items listbox-items)
+ listbox-items))
+ (keys (fill-listbox listbox sorted-items)))
+
+ (define (choice->item str)
+ ;; Return the item that corresponds to STR.
+ (match (find (match-lambda
+ ((key . item)
+ (string=? str (listbox-item->text item))))
+ keys)
+ ((key . item) item)
+ (#f (raise (condition (&installer-step-abort))))))
+
+ ;; On every listbox element change, check if we need to skip it. If yes,
+ ;; depending on the 'last-listbox-key', jump forward or backward. If no,
+ ;; do nothing.
+ (add-component-callback
+ listbox
+ (lambda (component)
+ (let* ((current-key (current-listbox-entry listbox))
+ (listbox-keys (map car keys))
+ (last-key (last-listbox-key))
+ (item (assoc-ref keys current-key))
+ (prev-key (previous-key listbox-keys current-key))
+ (next-key (next-key listbox-keys current-key)))
+ ;; Update last-listbox-key before a potential call to
+ ;; set-current-listbox-entry-by-key, because it will immediately
+ ;; cause this callback to be called for the new entry.
+ (last-listbox-key current-key)
+ (when (skip-item-procedure? item)
+ (when (eq? prev-key last-key)
+ (if next-key
+ (set-current-listbox-entry-by-key listbox next-key)
+ (set-current-listbox-entry-by-key listbox prev-key)))
+ (when (eq? next-key last-key)
+ (if prev-key
+ (set-current-listbox-entry-by-key listbox prev-key)
+ (set-current-listbox-entry-by-key listbox next-key)))))))
+
+ (when listbox-default-item
+ (set-default-item listbox keys listbox-default-item))
+
+ (when allow-delete?
+ (form-add-hotkey form KEY-DELETE))
- (add-form-to-grid grid form #t)
- (make-wrapped-grid-window grid title)
+ (add-form-to-grid grid form #t)
+ (make-wrapped-grid-window grid title)
- (receive (exit-reason argument)
- (run-form form)
- (dynamic-wind
- (const #t)
- (lambda ()
- (case exit-reason
- ((exit-component)
- (cond
- ((components=? argument button)
- (button-callback-procedure))
- ((and button2
- (components=? argument button2))
- (button2-callback-procedure))
- ((components=? argument listbox)
- (if listbox-allow-multiple?
- (let* ((entries (listbox-selection listbox))
- (items (map (lambda (entry)
- (assoc-ref keys entry))
- entries)))
- (listbox-callback-procedure items))
- (let* ((entry (current-listbox-entry listbox))
- (item (assoc-ref keys entry)))
- (listbox-callback-procedure item))))))
- ((exit-hotkey)
- (let* ((entry (current-listbox-entry listbox))
- (item (assoc-ref keys entry)))
- (hotkey-callback-procedure argument item)))))
- (lambda ()
- (destroy-form-and-pop form))))))
+ (receive (exit-reason argument)
+ (run-form-with-clients form
+ `(list-selection (title ,title)
+ (multiple-choices?
+ ,listbox-allow-multiple?)
+ (items
+ ,(map listbox-item->text
+ listbox-items))))
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (match exit-reason
+ ('exit-component
+ (cond
+ ((components=? argument button)
+ (button-callback-procedure))
+ ((and button2
+ (components=? argument button2))
+ (button2-callback-procedure))
+ ((components=? argument listbox)
+ (if listbox-allow-multiple?
+ (let* ((entries (listbox-selection listbox))
+ (items (map (lambda (entry)
+ (assoc-ref keys entry))
+ entries)))
+ (listbox-callback-procedure items))
+ (let* ((entry (current-listbox-entry listbox))
+ (item (assoc-ref keys entry)))
+ (listbox-callback-procedure item))))))
+ ('exit-fd-ready
+ (let* ((choice argument)
+ (item (if listbox-allow-multiple?
+ (map choice->item choice)
+ (choice->item choice))))
+ (client-callback-procedure item)))
+ ('exit-hotkey
+ (let* ((entry (current-listbox-entry listbox))
+ (item (assoc-ref keys entry)))
+ (hotkey-callback-procedure argument item)))))
+ (lambda ()
+ (destroy-form-and-pop form)))))))
(define* (run-scale-page #:key
title
@@ -498,48 +653,65 @@ ITEMS when 'Ok' is pressed."
items
selection))
- (let* ((checkbox-tree
- (make-checkboxtree -1 -1
- checkbox-tree-height
- FLAG-BORDER))
- (info-textbox
- (make-reflowed-textbox -1 -1 info-text
- info-textbox-width
- #:flags FLAG-BORDER))
- (ok-button (make-button -1 -1 (G_ "OK")))
- (exit-button (make-button -1 -1 (G_ "Exit")))
- (grid (vertically-stacked-grid
- GRID-ELEMENT-COMPONENT info-textbox
- GRID-ELEMENT-COMPONENT checkbox-tree
- GRID-ELEMENT-SUBGRID
- (horizontal-stacked-grid
- GRID-ELEMENT-COMPONENT ok-button
- GRID-ELEMENT-COMPONENT exit-button)))
- (keys (fill-checkbox-tree checkbox-tree items))
- (form (make-form #:flags FLAG-NOF12)))
+ (let loop ()
+ (let* ((checkbox-tree
+ (make-checkboxtree -1 -1
+ checkbox-tree-height
+ FLAG-BORDER))
+ (info-textbox
+ (make-reflowed-textbox -1 -1 info-text
+ info-textbox-width
+ #:flags FLAG-BORDER))
+ (ok-button (make-button -1 -1 (G_ "OK")))
+ (exit-button (make-button -1 -1 (G_ "Exit")))
+ (grid (vertically-stacked-grid
+ GRID-ELEMENT-COMPONENT info-textbox
+ GRID-ELEMENT-COMPONENT checkbox-tree
+ GRID-ELEMENT-SUBGRID
+ (horizontal-stacked-grid
+ GRID-ELEMENT-COMPONENT ok-button
+ GRID-ELEMENT-COMPONENT exit-button)))
+ (keys (fill-checkbox-tree checkbox-tree items))
+ (form (make-form #:flags FLAG-NOF12)))
- (add-form-to-grid grid form #t)
- (make-wrapped-grid-window grid title)
+ (define (choice->item str)
+ ;; Return the item that corresponds to STR.
+ (match (find (match-lambda
+ ((key . item)
+ (string=? str (item->text item))))
+ keys)
+ ((key . item) item)
+ (#f (raise (condition (&installer-step-abort))))))
- (receive (exit-reason argument)
- (run-form form)
- (dynamic-wind
- (const #t)
- (lambda ()
- (case exit-reason
- ((exit-component)
- (cond
- ((components=? argument ok-button)
- (let* ((entries (current-checkbox-selection checkbox-tree))
- (current-items (map (lambda (entry)
- (assoc-ref keys entry))
- entries)))
- (ok-button-callback-procedure)
- current-items))
- ((components=? argument exit-button)
- (exit-button-callback-procedure))))))
- (lambda ()
- (destroy-form-and-pop form))))))
+ (add-form-to-grid grid form #t)
+ (make-wrapped-grid-window grid title)
+
+ (receive (exit-reason argument)
+ (run-form-with-clients form
+ `(checkbox-list (title ,title)
+ (text ,info-text)
+ (items
+ ,(map item->text items))))
+ (dynamic-wind
+ (const #t)
+
+ (lambda ()
+ (match exit-reason
+ ('exit-component
+ (cond
+ ((components=? argument ok-button)
+ (let* ((entries (current-checkbox-selection checkbox-tree))
+ (current-items (map (lambda (entry)
+ (assoc-ref keys entry))
+ entries)))
+ (ok-button-callback-procedure)
+ current-items))
+ ((components=? argument exit-button)
+ (exit-button-callback-procedure))))
+ ('exit-fd-ready
+ (map choice->item argument))))
+ (lambda ()
+ (destroy-form-and-pop form)))))))
(define* (edit-file file #:key locale)
"Spawn an editor for FILE."
@@ -547,9 +719,8 @@ ITEMS when 'Ok' is pressed."
(newt-suspend)
;; Use Nano because it syntax-highlights Scheme by default.
;; TODO: Add a menu to choose an editor?
- (run-shell-command (string-append "/run/current-system/profile/bin/nano "
- file)
- #:locale locale)
+ (run-command (list "/run/current-system/profile/bin/nano" file)
+ #:locale locale)
(newt-resume))
(define* (run-file-textbox-page #:key
@@ -606,13 +777,16 @@ ITEMS when 'Ok' is pressed."
text))
(receive (exit-reason argument)
- (run-form form)
+ (run-form-with-clients form
+ `(file-dialog (title ,title)
+ (text ,info-text)
+ (file ,file)))
(define result
(dynamic-wind
(const #t)
(lambda ()
- (case exit-reason
- ((exit-component)
+ (match exit-reason
+ ('exit-component
(cond
((components=? argument ok-button)
(ok-button-callback-procedure))
@@ -621,10 +795,15 @@ ITEMS when 'Ok' is pressed."
(exit-button-callback-procedure))
((and edit-button?
(components=? argument edit-button))
- (edit-file file))))))
+ (edit-file file))))
+ ('exit-fd-ready
+ (if argument
+ (ok-button-callback-procedure)
+ (exit-button-callback-procedure)))))
(lambda ()
(destroy-form-and-pop form))))
- (if (components=? argument edit-button)
+ (if (and (eq? exit-reason 'exit-component)
+ (components=? argument edit-button))
(loop) ;recurse in tail position
result)))))
diff --git a/gnu/installer/newt/partition.scm b/gnu/installer/newt/partition.scm
index 3cba7f77dd..c925e410a9 100644
--- a/gnu/installer/newt/partition.scm
+++ b/gnu/installer/newt/partition.scm
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018, 2019 Mathieu Othacehe <m.othacehe@gmail.com>
-;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; This file is part of GNU Guix.
@@ -682,6 +682,12 @@ by pressing the Exit button.~%~%")))
#:allow-delete? #t
#:button-text (G_ "OK")
#:button-callback-procedure button-ok-action
+
+ ;; Consider client replies equivalent to hitting the "OK" button.
+ ;; XXX: In practice this means that clients cannot do anything but
+ ;; approve the predefined list of partitions.
+ #:client-callback-procedure (lambda (_) (button-ok-action))
+
#:button2-text (G_ "Exit")
#:button2-callback-procedure button-exit-action
#:listbox-callback-procedure listbox-action
diff --git a/gnu/installer/newt/user.scm b/gnu/installer/newt/user.scm
index b01d52172b..ad711d665a 100644
--- a/gnu/installer/newt/user.scm
+++ b/gnu/installer/newt/user.scm
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
-;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2019 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; This file is part of GNU Guix.
@@ -23,6 +23,7 @@
#:use-module ((gnu installer steps) #:select (&installer-step-abort))
#:use-module (gnu installer newt page)
#:use-module (gnu installer newt utils)
+ #:use-module (gnu installer utils)
#:use-module (guix i18n)
#:use-module (newt)
#:use-module (ice-9 match)
@@ -115,6 +116,7 @@ REAL-NAME, and HOME-DIRECTORY as the initial values in the form."
GRID-ELEMENT-SUBGRID entry-grid
GRID-ELEMENT-SUBGRID button-grid)
title)
+
(let ((error-page
(lambda ()
(run-error-page (G_ "Empty inputs are not allowed.")
@@ -230,33 +232,45 @@ administrator (\"root\").")
(set-current-component form ok-button))
(receive (exit-reason argument)
- (run-form form)
+ (run-form-with-clients form '(add-users))
(dynamic-wind
(const #t)
(lambda ()
- (when (eq? exit-reason 'exit-component)
- (cond
- ((components=? argument add-button)
- (run (cons (run-user-add-page) users)))
- ((components=? argument del-button)
- (let* ((current-user-key (current-listbox-entry listbox))
- (users
- (map (cut assoc-ref <> 'user)
- (remove (lambda (element)
- (equal? (assoc-ref element 'key)
- current-user-key))
- listbox-elements))))
- (run users)))
- ((components=? argument ok-button)
- (when (null? users)
- (run-error-page (G_ "Please create at least one user.")
- (G_ "No user"))
- (run users))
- (reverse users))
- ((components=? argument exit-button)
- (raise
- (condition
- (&installer-step-abort)))))))
+ (match exit-reason
+ ('exit-component
+ (cond
+ ((components=? argument add-button)
+ (run (cons (run-user-add-page) users)))
+ ((components=? argument del-button)
+ (let* ((current-user-key (current-listbox-entry listbox))
+ (users
+ (map (cut assoc-ref <> 'user)
+ (remove (lambda (element)
+ (equal? (assoc-ref element 'key)
+ current-user-key))
+ listbox-elements))))
+ (run users)))
+ ((components=? argument ok-button)
+ (when (null? users)
+ (run-error-page (G_ "Please create at least one user.")
+ (G_ "No user"))
+ (run users))
+ (reverse users))
+ ((components=? argument exit-button)
+ (raise
+ (condition
+ (&installer-step-abort))))))
+ ('exit-fd-ready
+ ;; Read the complete user list at once.
+ (match argument
+ ((('user ('name names) ('real-name real-names)
+ ('home-directory homes) ('password passwords))
+ ..1)
+ (map (lambda (name real-name home password)
+ (user (name name) (real-name real-name)
+ (home-directory home)
+ (password password)))
+ names real-names homes passwords))))))
(lambda ()
(destroy-form-and-pop form))))))
diff --git a/gnu/installer/newt/welcome.scm b/gnu/installer/newt/welcome.scm
index aec3e7a612..1b4b2df816 100644
--- a/gnu/installer/newt/welcome.scm
+++ b/gnu/installer/newt/welcome.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -11,16 +12,20 @@
;;; 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
-
;;;
;;; 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 installer newt welcome)
+ #:use-module (gnu installer steps)
#:use-module (gnu installer utils)
+ #:use-module (gnu installer newt page)
#:use-module (gnu installer newt utils)
#:use-module (guix build syscalls)
#:use-module (guix i18n)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
#:use-module (ice-9 match)
#:use-module (ice-9 receive)
#:use-module (newt)
@@ -66,24 +71,43 @@ we want this page to occupy all the screen space available."
GRID-ELEMENT-COMPONENT options-listbox))
(form (make-form)))
+ (define (choice->item str)
+ ;; Return the item that corresponds to STR.
+ (match (find (match-lambda
+ ((key . item)
+ (string=? str (listbox-item->text item))))
+ keys)
+ ((key . item) item)
+ (#f (raise (condition (&installer-step-abort))))))
+
(set-textbox-text logo-textbox (read-all logo))
(add-form-to-grid grid form #t)
(make-wrapped-grid-window grid title)
(receive (exit-reason argument)
- (run-form form)
+ (run-form-with-clients form
+ `(menu (title ,title)
+ (text ,info-text)
+ (items
+ ,(map listbox-item->text
+ listbox-items))))
(dynamic-wind
(const #t)
(lambda ()
- (when (eq? exit-reason 'exit-component)
- (cond
- ((components=? argument options-listbox)
- (let* ((entry (current-listbox-entry options-listbox))
- (item (assoc-ref keys entry)))
- (match item
- ((text . proc)
- (proc))))))))
+ (match exit-reason
+ ('exit-component
+ (let* ((entry (current-listbox-entry options-listbox))
+ (item (assoc-ref keys entry)))
+ (match item
+ ((text . proc)
+ (proc)))))
+ ('exit-fd-ready
+ (let* ((choice argument)
+ (item (choice->item choice)))
+ (match item
+ ((text . proc)
+ (proc)))))))
(lambda ()
(destroy-form-and-pop form))))))
diff --git a/gnu/installer/steps.scm b/gnu/installer/steps.scm
index b2fc819d89..0b6d8e4649 100644
--- a/gnu/installer/steps.scm
+++ b/gnu/installer/steps.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018, 2019 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -19,6 +20,7 @@
(define-module (gnu installer steps)
#:use-module (guix records)
#:use-module (guix build utils)
+ #:use-module (gnu installer utils)
#:use-module (ice-9 match)
#:use-module (ice-9 pretty-print)
#:use-module (srfi srfi-1)
@@ -185,13 +187,18 @@ return the accumalated result so far."
#:todo-steps rest-steps
#:done-steps (append done-steps (list step))))))))
- (call-with-prompt 'raise-above
- (lambda ()
- (run '()
- #:todo-steps steps
- #:done-steps '()))
- (lambda (k condition)
- (raise condition))))
+ ;; Ignore SIGPIPE so that we don't die if a client closes the connection
+ ;; prematurely.
+ (sigaction SIGPIPE SIG_IGN)
+
+ (with-server-socket
+ (call-with-prompt 'raise-above
+ (lambda ()
+ (run '()
+ #:todo-steps steps
+ #:done-steps '()))
+ (lambda (k condition)
+ (raise condition)))))
(define (find-step-by-id steps id)
"Find and return the step in STEPS whose id is equal to ID."
@@ -249,3 +256,7 @@ found in RESULTS."
(pretty-print part port)))
configuration)
(flush-output-port port))))
+
+;;; Local Variables:
+;;; eval: (put 'with-server-socket 'scheme-indent-function 0)
+;;; End:
diff --git a/gnu/installer/tests.scm b/gnu/installer/tests.scm
new file mode 100644
index 0000000000..6f5393e3ab
--- /dev/null
+++ b/gnu/installer/tests.scm
@@ -0,0 +1,340 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; 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 installer tests)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 regex)
+ #:use-module (ice-9 pretty-print)
+ #:export (&pattern-not-matched
+ pattern-not-matched?
+
+ %installer-socket-file
+ open-installer-socket
+
+ converse
+ conversation-log-port
+
+ choose-locale+keyboard
+ enter-host-name+passwords
+ choose-services
+ choose-partitioning
+ conclude-installation
+
+ edit-configuration-file))
+
+;;; Commentary:
+;;;
+;;; This module provides tools to test the guided "graphical" installer in a
+;;; non-interactive fashion. The core of it is 'converse': it allows you to
+;;; state Expect-style dialogues, which happen over the Unix-domain socket the
+;;; installer listens to. Higher-level procedures such as
+;;; 'choose-locale+keyboard' are provided to perform specific parts of the
+;;; dialogue.
+;;;
+;;; Code:
+
+(define %installer-socket-file
+ ;; Socket the installer listens to.
+ "/var/guix/installer-socket")
+
+(define* (open-installer-socket #:optional (file %installer-socket-file))
+ "Return a socket connected to the installer."
+ (let ((sock (socket AF_UNIX SOCK_STREAM 0)))
+ (connect sock AF_UNIX file)
+ sock))
+
+(define-condition-type &pattern-not-matched &error
+ pattern-not-matched?
+ (pattern pattern-not-matched-pattern)
+ (sexp pattern-not-matched-sexp))
+
+(define (pattern-error pattern sexp)
+ (raise (condition
+ (&pattern-not-matched
+ (pattern pattern) (sexp sexp)))))
+
+(define conversation-log-port
+ ;; Port where debugging info is logged
+ (make-parameter (current-error-port)))
+
+(define (converse-debug pattern)
+ (format (conversation-log-port)
+ "conversation expecting pattern ~s~%"
+ pattern))
+
+(define-syntax converse
+ (lambda (s)
+ "Convert over PORT: read sexps from there, match them against each
+PATTERN, and send the corresponding REPLY. Raise to '&pattern-not-matched'
+when one of the PATTERNs is not matched."
+
+ ;; XXX: Strings that appear in PATTERNs must be in the language the
+ ;; installer is running in. In the future, we should add support to allow
+ ;; writing English strings in PATTERNs and have the pattern matcher
+ ;; automatically translate them.
+
+ ;; Here we emulate 'pmatch' syntax on top of 'match'. This is ridiculous
+ ;; but that's because 'pmatch' compares objects with 'eq?', making it
+ ;; pretty useless, and it doesn't support ellipses and such.
+
+ (define (quote-pattern s)
+ ;; Rewrite the pattern S from pmatch style (a ,b) to match style like
+ ;; ('a b).
+ (with-ellipsis :::
+ (syntax-case s (unquote _ ...)
+ ((unquote id) #'id)
+ (_ #'_)
+ (... #'...)
+ (id
+ (identifier? #'id)
+ #''id)
+ ((lst :::) (map quote-pattern #'(lst :::)))
+ (pattern #'pattern))))
+
+ (define (match-pattern s)
+ ;; Match one pattern without a guard.
+ (syntax-case s ()
+ ((port (pattern reply) continuation)
+ (with-syntax ((pattern (quote-pattern #'pattern)))
+ #'(let ((pat 'pattern))
+ (converse-debug pat)
+ (match (read port)
+ (pattern
+ (let ((data (call-with-values (lambda () reply)
+ list)))
+ (for-each (lambda (obj)
+ (write obj port)
+ (newline port))
+ data)
+ (force-output port)
+ (continuation port)))
+ (sexp
+ (pattern-error pat sexp))))))))
+
+ (syntax-case s ()
+ ((_ port (pattern reply) rest ...)
+ (match-pattern #'(port (pattern reply)
+ (lambda (port)
+ (converse port rest ...)))))
+ ((_ port (pattern guard reply) rest ...)
+ #`(let ((skip? (not guard))
+ (next (lambda (p)
+ (converse p rest ...))))
+ (if skip?
+ (next port)
+ #,(match-pattern #'(port (pattern reply) next)))))
+ ((_ port)
+ #t))))
+
+(define* (choose-locale+keyboard port
+ #:key
+ (language "English")
+ (location "Hong Kong")
+ (timezone '("Europe" "Zagreb"))
+ (keyboard
+ '("English (US)"
+ "English (intl., with AltGr dead keys)")))
+ "Converse over PORT with the guided installer to choose the specified
+LANGUAGE, LOCATION, TIMEZONE, and KEYBOARD."
+ (converse port
+ ((list-selection (title "Locale language")
+ (multiple-choices? #f)
+ (items _))
+ language)
+ ((list-selection (title "Locale location")
+ (multiple-choices? #f)
+ (items _))
+ location)
+ ((menu (title "GNU Guix install")
+ (text _)
+ (items (,guided _ ...))) ;"Guided graphical installation"
+ guided)
+ ((list-selection (title "Timezone")
+ (multiple-choices? #f)
+ (items _))
+ (first timezone))
+ ((list-selection (title "Timezone")
+ (multiple-choices? #f)
+ (items _))
+ (second timezone))
+ ((list-selection (title "Layout")
+ (multiple-choices? #f)
+ (items _))
+ (first keyboard))
+ ((list-selection (title "Variant")
+ (multiple-choices? #f)
+ (items _))
+ (second keyboard))))
+
+(define* (enter-host-name+passwords port
+ #:key
+ (host-name "guix")
+ (root-password "foo")
+ (users '(("alice" "pass1")
+ ("bob" "pass2")
+ ("charlie" "pass3"))))
+ "Converse over PORT with the guided installer to choose HOST-NAME,
+ROOT-PASSWORD, and USERS."
+ (converse port
+ ((input (title "Hostname") (text _) (default _))
+ host-name)
+ ((input (title "System administrator password") (text _) (default _))
+ root-password)
+ ((input (title "Password confirmation required") (text _) (default _))
+ root-password)
+ ((add-users)
+ (match users
+ (((names passwords) ...)
+ (map (lambda (name password)
+ `(user (name ,name) (real-name ,(string-titlecase name))
+ (home-directory ,(string-append "/home/" name))
+ (password ,password)))
+ names passwords))))))
+
+(define* (choose-services port
+ #:key
+ (desktop-environments '("GNOME"))
+ (choose-network-service?
+ (lambda (service)
+ (or (string-contains service "SSH")
+ (string-contains service "NSS"))))
+ (choose-network-management-tool?
+ (lambda (service)
+ (string-contains service "DHCP"))))
+ "Converse over PORT to choose networking services."
+ (converse port
+ ((checkbox-list (title "Desktop environment") (text _)
+ (items _))
+ desktop-environments)
+ ((checkbox-list (title "Network service") (text _)
+ (items ,services))
+ (filter choose-network-service? services))
+
+ ;; The "Network management" dialog shows up only when no desktop
+ ;; environments have been selected, hence the guard.
+ ((list-selection (title "Network management")
+ (multiple-choices? #f)
+ (items ,services))
+ (null? desktop-environments)
+ (find choose-network-management-tool? services))))
+
+(define (edit-configuration-file file)
+ "Edit FILE, an operating system configuration file generated by the
+installer, by adding a marionette service such that the installed OS is
+instrumented for further testing."
+ (define (read-expressions port)
+ (let loop ((result '()))
+ (match (read port)
+ ((? eof-object?)
+ (reverse result))
+ (exp
+ (loop (cons exp result))))))
+
+ (define (edit exp)
+ (match exp
+ (('operating-system _ ...)
+ `(marionette-operating-system ,exp
+ #:imported-modules
+ '((gnu services herd)
+ (guix build utils)
+ (guix combinators))))
+ (_
+ exp)))
+
+ (let ((content (call-with-input-file file read-expressions)))
+ (call-with-output-file file
+ (lambda (port)
+ (format port "\
+;; Operating system configuration edited for automated testing.~%~%")
+
+ (pretty-print '(use-modules (gnu tests)) port)
+ (for-each (lambda (exp)
+ (pretty-print (edit exp) port)
+ (newline port))
+ content)))
+
+ #t))
+
+(define* (choose-partitioning port
+ #:key
+ (encrypted? #t)
+ (passphrase "thepassphrase")
+ (edit-configuration-file
+ edit-configuration-file))
+ "Converse over PORT to choose the partitioning method. When ENCRYPTED? is
+true, choose full-disk encryption with PASSPHRASE as the LUKS passphrase.
+This conversation goes past the final dialog box that shows the configuration
+file, actually starting the installation process."
+ (converse port
+ ((list-selection (title "Partitioning method")
+ (multiple-choices? #f)
+ (items (,not-encrypted ,encrypted _ ...)))
+ (if encrypted?
+ encrypted
+ not-encrypted))
+ ((list-selection (title "Disk") (multiple-choices? #f)
+ (items (,disk _ ...)))
+ disk)
+
+ ;; The "Partition table" dialog pops up only if there's not already a
+ ;; partition table.
+ ((list-selection (title "Partition table")
+ (multiple-choices? #f)
+ (items _))
+ "gpt")
+ ((list-selection (title "Partition scheme")
+ (multiple-choices? #f)
+ (items (,one-partition _ ...)))
+ one-partition)
+ ((list-selection (title "Guided partitioning")
+ (multiple-choices? #f)
+ (items (,disk _ ...)))
+ disk)
+ ((input (title "Password required")
+ (text _) (default #f))
+ encrypted? ;only when ENCRYPTED?
+ passphrase)
+ ((input (title "Password confirmation required")
+ (text _) (default #f))
+ encrypted?
+ passphrase)
+ ((confirmation (title "Format disk?") (text _))
+ #t)
+ ((info (title "Preparing partitions") _ ...)
+ (values)) ;nothing to return
+ ((file-dialog (title "Configuration file")
+ (text _)
+ (file ,configuration-file))
+ (edit-configuration-file configuration-file))))
+
+(define (conclude-installation port)
+ "Conclude the installation by checking over PORT that we get the final
+messages once the 'guix system init' process has completed."
+ (converse port
+ ((pause) ;"Press Enter to continue."
+ #t)
+ ((installation-complete) ;congratulations!
+ (values))))
+
+;;; Local Variables:
+;;; eval: (put 'converse 'scheme-indent-function 1)
+;;; eval: (put 'with-ellipsis 'scheme-indent-function 1)
+;;; End:
diff --git a/gnu/installer/utils.scm b/gnu/installer/utils.scm
index 842bd02ced..0a91ae1e4a 100644
--- a/gnu/installer/utils.scm
+++ b/gnu/installer/utils.scm
@@ -21,7 +21,9 @@
#:use-module (guix utils)
#:use-module (guix build utils)
#:use-module (guix i18n)
+ #:use-module (srfi srfi-1)
#:use-module (srfi srfi-34)
+ #:use-module (ice-9 match)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 regex)
#:use-module (ice-9 format)
@@ -30,10 +32,15 @@
read-all
nearest-exact-integer
read-percentage
- run-shell-command
+ run-command
syslog-port
- syslog))
+ syslog
+
+ with-server-socket
+ current-server-socket
+ current-clients
+ send-to-clients))
(define* (read-lines #:optional (port (current-input-port)))
"Read lines from PORT and return them as a list."
@@ -61,44 +68,48 @@ number. If no percentage is found, return #f"
(and result
(string->number (match:substring result 1)))))
-(define* (run-shell-command command #:key locale)
- "Run COMMAND, a string, with Bash, and in the given LOCALE. Return true if
+(define* (run-command command #:key locale)
+ "Run COMMAND, a list of strings, in the given LOCALE. Return true if
COMMAND exited successfully, #f otherwise."
+ (define env (environ))
+
(define (pause)
(format #t (G_ "Press Enter to continue.~%"))
- (read-line (current-input-port)))
-
- (call-with-temporary-output-file
- (lambda (file port)
- (when locale
- (let ((supported? (false-if-exception
- (setlocale LC_ALL locale))))
- ;; If LOCALE is not supported, then set LANGUAGE, which might at
- ;; least give us translated messages.
- (if supported?
- (format port "export LC_ALL=\"~a\"~%" locale)
- (format port "export LANGUAGE=\"~a\"~%"
- (string-take locale
- (string-index locale #\_))))))
-
- (format port "exec ~a~%" command)
- (close port)
-
- (guard (c ((invoke-error? c)
- (newline)
- (format (current-error-port)
- (G_ "Command failed with exit code ~a.~%")
- (invoke-error-exit-status c))
- (syslog "command ~s failed with exit code ~a"
- command (invoke-error-exit-status c))
- (pause)
- #f))
- (syslog "running command ~s~%" command)
- (invoke "bash" "--init-file" file)
- (syslog "command ~s succeeded~%" command)
- (newline)
- (pause)
- #t))))
+ (send-to-clients '(pause))
+ (environ env) ;restore environment variables
+ (match (select (cons (current-input-port) (current-clients))
+ '() '())
+ (((port _ ...) _ _)
+ (read-line port))))
+
+ (setenv "PATH" "/run/current-system/profile/bin")
+
+ (when locale
+ (let ((supported? (false-if-exception
+ (setlocale LC_ALL locale))))
+ ;; If LOCALE is not supported, then set LANGUAGE, which might at
+ ;; least give us translated messages.
+ (if supported?
+ (setenv "LC_ALL" locale)
+ (setenv "LANGUAGE"
+ (string-take locale
+ (string-index locale #\_))))))
+
+ (guard (c ((invoke-error? c)
+ (newline)
+ (format (current-error-port)
+ (G_ "Command failed with exit code ~a.~%")
+ (invoke-error-exit-status c))
+ (syslog "command ~s failed with exit code ~a"
+ command (invoke-error-exit-status c))
+ (pause)
+ #f))
+ (syslog "running command ~s~%" command)
+ (apply invoke command)
+ (syslog "command ~s succeeded~%" command)
+ (newline)
+ (pause)
+ #t))
;;;
@@ -134,3 +145,76 @@ COMMAND exited successfully, #f otherwise."
(with-syntax ((fmt (string-append "installer[~d]: "
(syntax->datum #'fmt))))
#'(format (syslog-port) fmt (getpid) args ...))))))
+
+
+;;;
+;;; Client protocol.
+;;;
+
+(define %client-socket-file
+ ;; Unix-domain socket where the installer accepts connections.
+ "/var/guix/installer-socket")
+
+(define current-server-socket
+ ;; Socket on which the installer is currently accepting connections, or #f.
+ (make-parameter #f))
+
+(define current-clients
+ ;; List of currently connected clients.
+ (make-parameter '()))
+
+(define* (open-server-socket
+ #:optional (socket-file %client-socket-file))
+ "Open SOCKET-FILE as a Unix-domain socket to accept incoming connections and
+return it."
+ (mkdir-p (dirname socket-file))
+ (when (file-exists? socket-file)
+ (delete-file socket-file))
+ (let ((sock (socket AF_UNIX SOCK_STREAM 0)))
+ (bind sock AF_UNIX socket-file)
+ (listen sock 0)
+ sock))
+
+(define (call-with-server-socket thunk)
+ (if (current-server-socket)
+ (thunk)
+ (let ((socket (open-server-socket)))
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (parameterize ((current-server-socket socket))
+ (thunk)))
+ (lambda ()
+ (close-port socket))))))
+
+(define-syntax-rule (with-server-socket exp ...)
+ "Evaluate EXP with 'current-server-socket' parameterized to a currently
+accepting socket."
+ (call-with-server-socket (lambda () exp ...)))
+
+(define* (send-to-clients exp)
+ "Send EXP to all the current clients."
+ (define remainder
+ (fold (lambda (client remainder)
+ (catch 'system-error
+ (lambda ()
+ (write exp client)
+ (newline client)
+ (force-output client)
+ (cons client remainder))
+ (lambda args
+ ;; We might get EPIPE if the client disconnects; when that
+ ;; happens, remove CLIENT from the set of available clients.
+ (let ((errno (system-error-errno args)))
+ (if (memv errno (list EPIPE ECONNRESET ECONNABORTED))
+ (begin
+ (syslog "removing client ~s due to ~s while replying~%"
+ (fileno client) (strerror errno))
+ (false-if-exception (close-port client))
+ remainder)
+ (cons client remainder))))))
+ '()
+ (current-clients)))
+
+ (current-clients (reverse remainder))
+ exp)
diff --git a/gnu/local.mk b/gnu/local.mk
index 7c3e2648e9..cc219b42df 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -656,6 +656,7 @@ INSTALLER_MODULES = \
%D%/installer/record.scm \
%D%/installer/services.scm \
%D%/installer/steps.scm \
+ %D%/installer/tests.scm \
%D%/installer/timezone.scm \
%D%/installer/user.scm \
%D%/installer/utils.scm \
@@ -713,10 +714,11 @@ dist_patch_DATA = \
%D%/packages/patches/aegisub-boost68.patch \
%D%/packages/patches/agg-am_c_prototype.patch \
%D%/packages/patches/akonadi-paths.patch \
- %D%/packages/patches/akonadi-Revert-Make-installation-properly-relocatabl.patch \
+ %D%/packages/patches/akonadi-Revert-Make-installation-properly-relo.patch \
%D%/packages/patches/akonadi-timestamps.patch \
%D%/packages/patches/allegro-mesa-18.2.5-and-later.patch \
%D%/packages/patches/amule-crypto-6.patch \
+ %D%/packages/patches/anki-mpv-args.patch \
%D%/packages/patches/antiword-CVE-2014-8123.patch \
%D%/packages/patches/antlr3-3_1-fix-java8-compilation.patch \
%D%/packages/patches/antlr3-3_3-fix-java8-compilation.patch \
@@ -801,7 +803,6 @@ dist_patch_DATA = \
%D%/packages/patches/cpufrequtils-fix-aclocal.patch \
%D%/packages/patches/crawl-upgrade-saves.patch \
%D%/packages/patches/crda-optional-gcrypt.patch \
- %D%/packages/patches/csvkit-fix-tests.patch \
%D%/packages/patches/clucene-contribs-lib.patch \
%D%/packages/patches/cube-nocheck.patch \
%D%/packages/patches/curl-use-ssl-cert-env.patch \
@@ -988,6 +989,7 @@ dist_patch_DATA = \
%D%/packages/patches/guile-1.8-cpp-4.5.patch \
%D%/packages/patches/guile-2.2-default-utf8.patch \
%D%/packages/patches/guile-2.2-skip-oom-test.patch \
+ %D%/packages/patches/guile-3.0-crash.patch \
%D%/packages/patches/guile-default-utf8.patch \
%D%/packages/patches/guile-gdbm-ffi-support-gdbm-1.14.patch \
%D%/packages/patches/guile-finalization-crash.patch \
@@ -1123,7 +1125,6 @@ dist_patch_DATA = \
%D%/packages/patches/libmpeg2-global-symbol-test.patch \
%D%/packages/patches/libmygpo-qt-fix-qt-5.11.patch \
%D%/packages/patches/libmygpo-qt-missing-qt5-modules.patch \
- %D%/packages/patches/libseccomp-open-aarch64.patch \
%D%/packages/patches/libsndfile-armhf-type-checks.patch \
%D%/packages/patches/libsndfile-CVE-2017-8361-8363-8365.patch \
%D%/packages/patches/libsndfile-CVE-2017-8362.patch \
@@ -1265,7 +1266,7 @@ dist_patch_DATA = \
%D%/packages/patches/sdl-pango-api_additions.patch \
%D%/packages/patches/sdl-pango-blit_overflow.patch \
%D%/packages/patches/sdl-pango-fillrect_crash.patch \
- %D%/packages/patches/sdl-pango-fix-explicit-SDLPango_CopyFTBitmapToSurface.patch \
+ %D%/packages/patches/sdl-pango-fix-explicit-SDLPango_CopyFTBitmapTo.patch \
%D%/packages/patches/sdl-pango-matrix_declarations.patch \
%D%/packages/patches/sdl-pango-sans-serif.patch \
%D%/packages/patches/patchutils-test-perms.patch \
@@ -1357,6 +1358,7 @@ dist_patch_DATA = \
%D%/packages/patches/qemu-CVE-2020-1711.patch \
%D%/packages/patches/qemu-CVE-2020-7039.patch \
%D%/packages/patches/qemu-CVE-2020-7211.patch \
+ %D%/packages/patches/qemu-CVE-2020-8608.patch \
%D%/packages/patches/qemu-fix-documentation-build-failure.patch \
%D%/packages/patches/qrcodegen-cpp-make-install.patch \
%D%/packages/patches/qt4-ldflags.patch \
@@ -1415,8 +1417,8 @@ dist_patch_DATA = \
%D%/packages/patches/snappy-add-O2-flag-in-CmakeLists.txt.patch \
%D%/packages/patches/sooperlooper-build-with-wx-30.patch \
%D%/packages/patches/soundconverter-remove-gconf-dependency.patch \
- %D%/packages/patches/spice-fix-test-armhf.patch \
%D%/packages/patches/steghide-fixes.patch \
+ %D%/packages/patches/suitesparse-mongoose-cmake.patch \
%D%/packages/patches/superlu-dist-awpm-grid.patch \
%D%/packages/patches/superlu-dist-scotchmetis.patch \
%D%/packages/patches/supertux-unbundle-squirrel.patch \
@@ -1497,7 +1499,6 @@ dist_patch_DATA = \
%D%/packages/patches/wicd-wpa2-ttls.patch \
%D%/packages/patches/wmctrl-64-fix.patch \
%D%/packages/patches/wmfire-update-for-new-gdk-versions.patch \
- %D%/packages/patches/woff2-libbrotli.patch \
%D%/packages/patches/wordnet-CVE-2008-2149.patch \
%D%/packages/patches/wordnet-CVE-2008-3908-pt1.patch \
%D%/packages/patches/wordnet-CVE-2008-3908-pt2.patch \
diff --git a/gnu/packages/admin.scm b/gnu/packages/admin.scm
index 6fb342dfee..af29dc30fe 100644
--- a/gnu/packages/admin.scm
+++ b/gnu/packages/admin.scm
@@ -211,10 +211,10 @@ and provides a \"top-like\" mode (monitoring).")
`(("pkg-config" ,pkg-config)
;; This is the Guile we use as a cross-compiler...
- ("guile" ,guile-2.2)))
+ ("guile" ,guile-2.2.7)))
(inputs
;; ... and this is the one that appears in shebangs when cross-compiling.
- `(("guile" ,guile-2.2) ;for <https://bugs.gnu.org/37757>
+ `(("guile" ,guile-2.2.7) ;for <https://bugs.gnu.org/37757>
;; The 'shepherd' command uses Readline when used interactively. It's
;; an unusual use case though, so we don't propagate it.
diff --git a/gnu/packages/assembly.scm b/gnu/packages/assembly.scm
index 1ad49baf8e..0fdddc88e9 100644
--- a/gnu/packages/assembly.scm
+++ b/gnu/packages/assembly.scm
@@ -111,7 +111,7 @@ has strong support for macros.")
(inputs
`(("python" ,python-wrapper)
("xmlto" ,xmlto)))
- (home-page "http://yasm.tortall.net/")
+ (home-page "https://yasm.tortall.net/")
(synopsis "Rewrite of the NASM assembler")
(description
"Yasm is a complete rewrite of the NASM assembler.
diff --git a/gnu/packages/audio.scm b/gnu/packages/audio.scm
index d0f55a96b8..8be5c9c9af 100644
--- a/gnu/packages/audio.scm
+++ b/gnu/packages/audio.scm
@@ -45,26 +45,14 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu packages audio)
- #:use-module (guix packages)
- #:use-module (guix download)
- #:use-module (guix git-download)
- #:use-module (guix utils)
- #:use-module ((guix licenses) #:prefix license:)
- #:use-module (guix build-system gnu)
- #:use-module (guix build-system waf)
- #:use-module (guix build-system trivial)
- #:use-module (guix build-system cmake)
- #:use-module (guix build-system meson)
- #:use-module (guix build-system python)
- #:use-module (guix build-system glib-or-gtk)
#:use-module (gnu packages)
#:use-module (gnu packages algebra)
#:use-module (gnu packages autotools)
#:use-module (gnu packages avahi)
- #:use-module (gnu packages boost)
#:use-module (gnu packages backup)
#:use-module (gnu packages base)
#:use-module (gnu packages bison)
+ #:use-module (gnu packages boost)
#:use-module (gnu packages check)
#:use-module (gnu packages compression)
#:use-module (gnu packages curl)
@@ -78,25 +66,29 @@
#:use-module (gnu packages gcc)
#:use-module (gnu packages gettext)
#:use-module (gnu packages glib)
- #:use-module (gnu packages gtk)
#:use-module (gnu packages gnome)
#:use-module (gnu packages gnunet) ; libmicrohttpd
#:use-module (gnu packages gperf)
+ #:use-module (gnu packages gtk)
+ #:use-module (gnu packages guile)
#:use-module (gnu packages icu4c)
#:use-module (gnu packages image)
- #:use-module (gnu packages ncurses)
- #:use-module (gnu packages onc-rpc)
- #:use-module (gnu packages qt)
#:use-module (gnu packages libbsd)
- #:use-module (gnu packages linux)
#:use-module (gnu packages libusb)
+ #:use-module (gnu packages linux)
#:use-module (gnu packages llvm)
+ #:use-module (gnu packages maths)
#:use-module (gnu packages mp3) ;taglib
+ #:use-module (gnu packages multiprecision)
+ #:use-module (gnu packages music)
+ #:use-module (gnu packages ncurses)
+ #:use-module (gnu packages onc-rpc)
#:use-module (gnu packages perl)
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages pulseaudio) ;libsndfile, libsamplerate
#:use-module (gnu packages python)
#:use-module (gnu packages python-xyz)
+ #:use-module (gnu packages qt)
#:use-module (gnu packages rdf)
#:use-module (gnu packages readline)
#:use-module (gnu packages sdl)
@@ -110,9 +102,18 @@
#:use-module (gnu packages xiph)
#:use-module (gnu packages xml)
#:use-module (gnu packages xorg)
- #:use-module (gnu packages maths)
- #:use-module (gnu packages multiprecision)
- #:use-module (gnu packages music)
+ #:use-module (guix build-system cmake)
+ #:use-module (guix build-system glib-or-gtk)
+ #:use-module (guix build-system gnu)
+ #:use-module (guix build-system meson)
+ #:use-module (guix build-system python)
+ #:use-module (guix build-system trivial)
+ #:use-module (guix build-system waf)
+ #:use-module (guix download)
+ #:use-module (guix git-download)
+ #:use-module ((guix licenses) #:prefix license:)
+ #:use-module (guix packages)
+ #:use-module (guix utils)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26))
@@ -3923,11 +3924,22 @@ as is the case with audio plugins.")
(list (string-append "PREFIX=" (assoc-ref %outputs "out")))
#:phases
(modify-phases %standard-phases
+ (delete 'configure) ; no configure script
(add-before 'build 'set-CC-variable-and-show-features
(lambda _
(setenv "CC" "gcc")
(invoke "make" "features")))
- (delete 'configure))))
+ (add-after 'install 'make-carla-executable
+ (lambda* (#:key outputs #:allow-other-keys)
+ (let ((out (assoc-ref outputs "out")))
+ (chmod (string-append out "/share/carla/carla") #o555)
+ #t)))
+ (add-after 'install 'wrap-executables
+ (lambda* (#:key outputs #:allow-other-keys)
+ (let ((out (assoc-ref outputs "out")))
+ (wrap-script (string-append out "/bin/carla")
+ `("PYTHONPATH" ":" prefix (,(getenv "PYTHONPATH"))))
+ #t))))))
(inputs
`(("alsa-lib" ,alsa-lib)
("ffmpeg" ,ffmpeg)
@@ -3945,7 +3957,10 @@ as is the case with audio plugins.")
("python-wrapper" ,python-wrapper)
("libx11" ,libx11)
("qtbase" ,qtbase)
- ("zlib" ,zlib)))
+ ("zlib" ,zlib)
+
+ ;; For WRAP-SCRIPT above.
+ ("guile" ,guile-2.2)))
(native-inputs
`(("pkg-config" ,pkg-config)))
(home-page "https://kx.studio/Applications:Carla")
diff --git a/gnu/packages/bioconductor.scm b/gnu/packages/bioconductor.scm
index 63687036fc..167cb00ece 100644
--- a/gnu/packages/bioconductor.scm
+++ b/gnu/packages/bioconductor.scm
@@ -4026,14 +4026,14 @@ position-specific scores within R and Bioconductor.")
(define-public r-atacseqqc
(package
(name "r-atacseqqc")
- (version "1.10.2")
+ (version "1.10.3")
(source
(origin
(method url-fetch)
(uri (bioconductor-uri "ATACseqQC" version))
(sha256
(base32
- "0dzrizacy3br8fiy1vnsl5zf242lg1hqv9dyv5ayqh2n480is57f"))))
+ "18zf90iksglbs13cwr4jjwsv332a19lf4bpdmy69jz8bpwrklv22"))))
(properties `((upstream-name . "ATACseqQC")))
(build-system r-build-system)
(propagated-inputs
@@ -4055,6 +4055,8 @@ position-specific scores within R and Bioconductor.")
("r-rsamtools" ,r-rsamtools)
("r-rtracklayer" ,r-rtracklayer)
("r-s4vectors" ,r-s4vectors)))
+ (native-inputs
+ `(("r-knitr" ,r-knitr)))
(home-page "https://bioconductor.org/packages/ATACseqQC/")
(synopsis "ATAC-seq quality control")
(description
@@ -4315,14 +4317,14 @@ visualization with image data.")
(define-public r-yamss
(package
(name "r-yamss")
- (version "1.12.0")
+ (version "1.12.1")
(source
(origin
(method url-fetch)
(uri (bioconductor-uri "yamss" version))
(sha256
(base32
- "1n49a2vg1667wycrjww29xfafngllvpb5nq5wy6pgn0akva91nky"))))
+ "12jr7hbrwhb1gfjadj1024hv80ra22miy46dn40nmsrbklkfn3rw"))))
(build-system r-build-system)
(propagated-inputs
`(("r-biocgenerics" ,r-biocgenerics)
@@ -4693,14 +4695,14 @@ based on @dfn{Continuous Wavelet Transform} (CWT).")
(define-public r-xcms
(package
(name "r-xcms")
- (version "3.8.1")
+ (version "3.8.2")
(source
(origin
(method url-fetch)
(uri (bioconductor-uri "xcms" version))
(sha256
(base32
- "18iglvlvlxrdwn2apdvihj9jxmx0kwm5z37rml67xcj9sfdi3bjb"))))
+ "0bfl56v3l6k31i11l09nx1yqfjy6z5yragm6k83z4w0mpgk18y7g"))))
(build-system r-build-system)
(propagated-inputs
`(("r-biobase" ,r-biobase)
@@ -5943,14 +5945,14 @@ delete entire rows with missing data.")
(define-public r-depecher
(package
(name "r-depecher")
- (version "1.2.1")
+ (version "1.2.2")
(source
(origin
(method url-fetch)
(uri (bioconductor-uri "DepecheR" version))
(sha256
(base32
- "08ja6ayvbax9m3x9w3xzi72z97miiha2nbsild1gp77n6sgn5i35"))))
+ "199j2kw0xnw7y4v1gakm2jgyc7zzlj8xh0570f2yjq55gp1kggbm"))))
(properties `((upstream-name . "DepecheR")))
(build-system r-build-system)
(propagated-inputs
@@ -5970,6 +5972,8 @@ delete entire rows with missing data.")
("r-reshape2" ,r-reshape2)
("r-robustbase" ,r-robustbase)
("r-viridis" ,r-viridis)))
+ (native-inputs
+ `(("r-knitr" ,r-knitr)))
(home-page "https://bioconductor.org/packages/DepecheR/")
(synopsis "Identify traits of clusters in high-dimensional entities")
(description
@@ -7290,14 +7294,14 @@ access.")
(define-public r-multiassayexperiment
(package
(name "r-multiassayexperiment")
- (version "1.12.3")
+ (version "1.12.4")
(source
(origin
(method url-fetch)
(uri (bioconductor-uri "MultiAssayExperiment" version))
(sha256
(base32
- "1vf6l88j3n6109j6sd08wfqxqpj2k20dvr8ll9zl1szsn18b4gny"))))
+ "01cnp00y5bk551c8gqgqp5468dvccg72i0rvh5cxgbx1c42zy6xn"))))
(properties
`((upstream-name . "MultiAssayExperiment")))
(build-system r-build-system)
diff --git a/gnu/packages/bioinformatics.scm b/gnu/packages/bioinformatics.scm
index 0c12e7c874..035a7bb808 100644
--- a/gnu/packages/bioinformatics.scm
+++ b/gnu/packages/bioinformatics.scm
@@ -6536,31 +6536,56 @@ Cuffdiff or Ballgown programs.")
(define-public taxtastic
(package
(name "taxtastic")
- (version "0.8.5")
+ (version "0.8.11")
(source (origin
- (method url-fetch)
- (uri (pypi-uri "taxtastic" version))
+ ;; The Pypi version does not include tests.
+ (method git-fetch)
+ (uri (git-reference
+ (url "https://github.com/fhcrc/taxtastic.git")
+ (commit (string-append "v" version))))
+ (file-name (git-file-name name version))
(sha256
(base32
- "03pysw79lsrvz4lwzis88j15067ffqbi4cid5pqhrlxmd6bh8rrk"))))
+ "1sv8mkg64jn7zdwf1jj71c16686yrwxk0apb1l8sjszy9p166g0p"))))
(build-system python-build-system)
(arguments
- `(#:python ,python-2
- #:phases
+ `(#:phases
(modify-phases %standard-phases
+ (add-after 'unpack 'prepare-directory
+ (lambda _
+ ;; The git checkout must be writable for tests.
+ (for-each make-file-writable (find-files "."))
+ ;; This test fails, but the error is not caught by the test
+ ;; framework, so the tests fail...
+ (substitute* "tests/test_taxit.py"
+ (("self.cmd_fails\\(''\\)")
+ "self.cmd_fails('nothing')"))
+ ;; This version file is expected to be created with git describe.
+ (mkdir-p "taxtastic/data")
+ (with-output-to-file "taxtastic/data/ver"
+ (lambda () (display ,version)))
+ #t))
+ (add-after 'unpack 'python37-compatibility
+ (lambda _
+ (substitute* "taxtastic/utils.py"
+ (("import csv") "import csv, errno")
+ (("os.errno") "errno"))
+ #t))
(replace 'check
- (lambda _ (invoke "python" "-m" "unittest" "discover" "-v") #t)))))
+ ;; Note, this fails to run with "-v" as it tries to write to a
+ ;; closed output stream.
+ (lambda _ (invoke "python" "-m" "unittest") #t)))))
(propagated-inputs
- `(("python-sqlalchemy" ,python2-sqlalchemy)
- ("python-decorator" ,python2-decorator)
- ("python-biopython" ,python2-biopython)
- ("python-pandas" ,python2-pandas)
- ("python-psycopg2" ,python2-psycopg2)
- ("python-fastalite" ,python2-fastalite)
- ("python-pyyaml" ,python2-pyyaml)
- ("python-six" ,python2-six)
- ("python-jinja2" ,python2-jinja2)
- ("python-dendropy" ,python2-dendropy)))
+ `(("python-sqlalchemy" ,python-sqlalchemy)
+ ("python-decorator" ,python-decorator)
+ ("python-biopython" ,python-biopython)
+ ("python-pandas" ,python-pandas)
+ ("python-psycopg2" ,python-psycopg2)
+ ("python-fastalite" ,python-fastalite)
+ ("python-pyyaml" ,python-pyyaml)
+ ("python-six" ,python-six)
+ ("python-jinja2" ,python-jinja2)
+ ("python-dendropy" ,python-dendropy)))
(home-page "https://github.com/fhcrc/taxtastic")
(synopsis "Tools for taxonomic naming and annotation")
(description
@@ -9091,6 +9116,8 @@ number detection tools.")
("r-rtracklayer" ,r-rtracklayer)
("r-s4vectors" ,r-s4vectors)
("r-zlibbioc" ,r-zlibbioc)))
+ (native-inputs
+ `(("r-knitr" ,r-knitr))) ; for vignettes
(inputs
`(("zlib" ,zlib)))
(home-page "https://github.com/al2na/methylKit")
@@ -9360,6 +9387,8 @@ analysis.")
("r-ggplot2" ,r-ggplot2)
("r-lattice" ,r-lattice)
("r-limma" ,r-limma)))
+ (native-inputs
+ `(("r-knitr" ,r-knitr))) ; for vignettes
(home-page "https://bioconductor.org/packages/release/bioc/html/vsn.html")
(synopsis "Variance stabilization and calibration for microarray data")
(description
@@ -13238,18 +13267,14 @@ in RNA-seq data.")
(define-public python-scanpy
(package
(name "python-scanpy")
- (version "1.4")
- ;; Fetch from git because the pypi tarball does not include tests.
+ (version "1.4.5.1")
(source
(origin
- (method git-fetch)
- (uri (git-reference
- (url "https://github.com/theislab/scanpy.git")
- (commit version)))
- (file-name (git-file-name name version))
+ (method url-fetch)
+ (uri (pypi-uri "scanpy" version))
(sha256
(base32
- "0zn6x6c0cnm1a20i6isigwb51g3pr9zpjk8r1minjqnxi5yc9pm4"))))
+ "14kh1ji70xxhmri5q8sgcibsidhr6f221wxrcw8a5xvibj5da17j"))))
(build-system python-build-system)
(arguments
`(#:phases
@@ -13276,18 +13301,23 @@ in RNA-seq data.")
("python-igraph" ,python-igraph)
("python-joblib" ,python-joblib)
("python-louvain" ,python-louvain)
+ ("python-legacy-api-wrap" ,python-legacy-api-wrap)
("python-matplotlib" ,python-matplotlib)
("python-natsort" ,python-natsort)
("python-networkx" ,python-networkx)
("python-numba" ,python-numba)
+ ("python-packaging" ,python-packaging)
("python-pandas" ,python-pandas)
+ ("python-patsy" ,python-patsy)
("python-scikit-learn" ,python-scikit-learn)
("python-scipy" ,python-scipy)
("python-seaborn" ,python-seaborn)
("python-statsmodels" ,python-statsmodels)
- ("python-tables" ,python-tables)))
+ ("python-tables" ,python-tables)
+ ("python-umap-learn" ,python-umap-learn)))
(native-inputs
- `(("python-pytest" ,python-pytest)))
+ `(("python-pytest" ,python-pytest)
+ ("python-setuptools-scm" ,python-setuptools-scm)))
(home-page "https://github.com/theislab/scanpy")
(synopsis "Single-Cell Analysis in Python.")
(description "Scanpy is a scalable toolkit for analyzing single-cell gene
@@ -13953,7 +13983,7 @@ datasets.")
(define-public ngless
(package
(name "ngless")
- (version "1.0.1")
+ (version "1.1.0")
(source
(origin
(method git-fetch)
@@ -13963,7 +13993,7 @@ datasets.")
(file-name (git-file-name name version))
(sha256
(base32
- "06ygv8q2zjqsnrid1302yrlhhvb8ik48nq6n0higk3i1mdc8r0dg"))))
+ "1wim8wpqyff080dfcazynrmjwqas38m24m0v350w245mmhrapdma"))))
(build-system haskell-build-system)
(arguments
`(#:haddock? #f ; The haddock phase fails with: NGLess/CmdArgs.hs:20:1:
@@ -14423,6 +14453,8 @@ repeated areas between contigs.")
(base32
"0fgygyzqgrq32dv6a00biq1p1cwi6kbl5iqblxq1kklj6b2mzmhs"))))
(build-system python-build-system)
+ (native-inputs
+ `(("python-joblib" ,python-joblib)))
(propagated-inputs
`(("python-click" ,python-click)
("python-cython" ,python-cython)
diff --git a/gnu/packages/ccache.scm b/gnu/packages/ccache.scm
index b3f0cbbd95..529742403e 100644
--- a/gnu/packages/ccache.scm
+++ b/gnu/packages/ccache.scm
@@ -30,30 +30,29 @@
(define-public ccache
(package
(name "ccache")
- (version "3.6")
+ (version "3.7.7")
(source
(origin
(method url-fetch)
- (uri (string-append "https://www.samba.org/ftp/ccache/ccache-"
- version ".tar.xz"))
+ (uri (string-append "https://github.com/ccache/ccache/releases/download/v"
+ version "/ccache-" version ".tar.xz"))
(sha256
- (base32 "07wv75xdcxpdkfsz9h5ffrm8pjbvr1dh6wnb02nyzz18cdbjkcd6"))))
+ (base32 "1kcqii3hr1008gj6jgfsjibwh2ryhsplc9z99m18xwa2zvbddhdp"))))
(build-system gnu-build-system)
(native-inputs `(("perl" ,perl) ; for test/run
("which" ,(@ (gnu packages base) which))))
(inputs `(("zlib" ,zlib)))
(arguments
'(#:phases (modify-phases %standard-phases
- (add-before 'check 'setup-tests
- (lambda _
- (substitute* '("unittest/test_hashutil.c" "test/suites/base.bash")
- (("#!/bin/sh") (string-append "#!" (which "sh"))))
- #t)))))
- (home-page "https://ccache.samba.org/")
+ (add-before 'check 'setup-tests
+ (lambda _
+ (substitute* '("unittest/test_hashutil.c" "test/suites/base.bash")
+ (("#!/bin/sh") (string-append "#!" (which "sh"))))
+ #t)))))
+ (home-page "https://ccache.dev/")
(synopsis "Compiler cache")
(description
"Ccache is a compiler cache. It speeds up recompilation by caching
previous compilations and detecting when the same compilation is being done
-again. Supported languages are C, C++, Objective-C, Objective-C++, and
-Fortran 77.")
+again. Supported languages are C, C++, Objective-C and Objective-C++.")
(license gpl3+)))
diff --git a/gnu/packages/chemistry.scm b/gnu/packages/chemistry.scm
index 3bdd406a47..2b3b5d7df6 100644
--- a/gnu/packages/chemistry.scm
+++ b/gnu/packages/chemistry.scm
@@ -3,6 +3,7 @@
;;; Copyright © 2018 Kei Kebreau <kkebreau@posteo.net>
;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2018 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2020 Björn Höfling <bjoern.hoefling@bjoernhoefling.de>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -147,7 +148,7 @@ powerful plugin architecture.")
`(#:python ,python-2
;; No test suite
#:tests? #f))
- (home-page "http://dirac.cnrs-orleans.fr/DomainFinder")
+ (home-page "http://dirac.cnrs-orleans.fr/DomainFinder.html")
(synopsis "Analysis of dynamical domains in proteins")
(description "DomainFinder is an interactive program for the determination
and characterization of dynamical domains in proteins. It can infer dynamical
@@ -290,7 +291,7 @@ analogy is that InChI is the bar-code for chemistry and chemical structures.")
;; Show documentation as PDF
(("PREFERENCES\\['documentation_style'\\] = 'html'")
"PREFERENCES['documentation_style'] = 'pdf'") ))))))
- (home-page "http://dirac.cnrs-orleans.fr/nMOLDYN/")
+ (home-page "http://dirac.cnrs-orleans.fr/nMOLDYN.html")
(synopsis "Analysis software for Molecular Dynamics trajectories")
(description "nMOLDYN is an interactive analysis program for Molecular Dynamics
simulations. It is especially designed for the computation and decomposition of
diff --git a/gnu/packages/chromium.scm b/gnu/packages/chromium.scm
index 275eb0588b..f73c76b827 100644
--- a/gnu/packages/chromium.scm
+++ b/gnu/packages/chromium.scm
@@ -826,7 +826,9 @@ from forcing GEXP-PROMISE."
;; Building Chromium takes ... a very long time. On a single core, a busy
;; mid-end x86 system may need more than 24 hours to complete the build.
- (properties '((timeout . 144000))) ;40 hours
+ (properties '((timeout . 144000) ;40 hours
+ ;; The linking step may take more than an hour on some hardware.
+ (max-silent-time . 7200)))
(home-page "https://github.com/Eloston/ungoogled-chromium")
(description
diff --git a/gnu/packages/compression.scm b/gnu/packages/compression.scm
index 9ccb34ad4b..c3b5632cba 100644
--- a/gnu/packages/compression.scm
+++ b/gnu/packages/compression.scm
@@ -25,6 +25,7 @@
;;; Copyright © 2018, 2019 Pierre Neidhardt <mail@ambrevar.xyz>
;;; Copyright © 2019 Nicolas Goaziou <mail@nicolasgoaziou.fr>
;;; Copyright © 2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2020 Björn Höfling <bjoern.hoefling@bjoernhoefling.de>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -424,7 +425,8 @@ compatible with bzip2 – both at file format and command line level.")
#:phases (modify-phases %standard-phases
(delete 'configure)) ; no configure script
#:make-flags (list (string-append "PREFIX=" %output))))
- (home-page "http://compression.ca/pbzip2/")
+ (home-page (string-append "https://web.archive.org/web/20180412020219/"
+ "http://compression.ca/pbzip2/"))
(synopsis "Parallel bzip2 implementation")
(description
"Pbzip2 is a parallel implementation of the bzip2 block-sorting file
@@ -822,7 +824,7 @@ time for compression ratio.")
("lzo" ,lzo)
("xz" ,xz)
("zlib" ,zlib)))
- (home-page "http://squashfs.sourceforge.net/")
+ (home-page "https://github.com/plougher/squashfs-tools")
(synopsis "Tools to create and extract squashfs file systems")
(description
"Squashfs is a highly compressed read-only file system for Linux. It uses
@@ -897,49 +899,6 @@ possible and can compress in parallel. This is especially useful for large
tarballs.")
(license license:bsd-2)))
-(define-public brotli
- (let ((commit "e992cce7a174d6e2b3486616499d26bb0bad6448")
- (revision "1"))
- (package
- (name "brotli")
- (version (string-append "0.1-" revision "."
- (string-take commit 7)))
- (source (origin
- (method git-fetch)
- (uri (git-reference
- (url "https://github.com/bagder/libbrotli.git")
- (commit commit)
- (recursive? #t)))
- (file-name (string-append name "-" version ".tar.xz"))
- (sha256
- (base32
- "1qxxsasvwbbbh6dl3138y9h3fg0q2v7xdk5jjc690bdg7g1wrj6n"))
- (modules '((guix build utils)))
- (snippet '(begin
- ;; This is a recursive submodule that is
- ;; unnecessary for this package, so delete it.
- (delete-file-recursively "brotli/terryfy")
- #t))))
- (build-system gnu-build-system)
- (native-inputs
- `(("autoconf" ,autoconf)
- ("automake" ,automake)
- ("libtool" ,libtool)))
- (arguments
- `(#:phases (modify-phases %standard-phases
- (add-after 'unpack 'autogen
- (lambda _
- (mkdir "m4")
- (invoke "autoreconf" "-vfi"))))))
- (home-page "https://github.com/bagder/libbrotli/")
- (synopsis "Implementation of the Brotli compression algorithm")
- (description
- "Brotli is a general-purpose lossless compression algorithm. It is
-similar in speed to deflate but offers denser compression. This package
-provides encoder and a decoder libraries: libbrotlienc and libbrotlidec,
-respectively, based on the reference implementation from Google.")
- (license license:expat))))
-
(define-public bsdiff
(package
(name "bsdiff")
@@ -1888,6 +1847,10 @@ with @code{deflate} but offers more dense compression.
The specification of the Brotli Compressed Data Format is defined in RFC 7932.")
(license license:expat)))
+(define-public brotli
+ ;; We used to provide an older version under the name "brotli".
+ (deprecated-package "brotli" google-brotli))
+
(define-public ucl
(package
(name "ucl")
diff --git a/gnu/packages/coq.scm b/gnu/packages/coq.scm
index 3eba39e5d0..f883c2f690 100644
--- a/gnu/packages/coq.scm
+++ b/gnu/packages/coq.scm
@@ -3,6 +3,7 @@
;;; Copyright © 2018, 2019 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2019 Dan Frumin <dfrumin@cs.ru.nl>
;;; Copyright © 2020 Brett Gilio <brettg@gnu.org>
+;;; Copyright © 2020 Björn Höfling <bjoern.hoefling@bjoernhoefling.de>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -353,7 +354,7 @@ assistant.")
(string-append "COQLIB=" (assoc-ref outputs "out")
"/lib/coq/")
"install"))))))
- (home-page "https://math-comp.github.io/math-comp/")
+ (home-page "https://math-comp.github.io/")
(synopsis "Mathematical Components for Coq")
(description "Mathematical Components for Coq has its origins in the formal
proof of the Four Colour Theorem. Since then it has grown to cover many areas
diff --git a/gnu/packages/cpp.scm b/gnu/packages/cpp.scm
index dba9ec75f6..0c5692b125 100644
--- a/gnu/packages/cpp.scm
+++ b/gnu/packages/cpp.scm
@@ -462,7 +462,7 @@ point and then, after each tween step, plugging back the result.")
;;
;; ld: CMakeFiles/absl_periodic_sampler_test.dir/internal/periodic_sampler_test.cc.o:
;; undefined reference to symbol '_ZN7testing4Mock16UnregisterLockedEPNS_8internal25UntypedFunctionMockerBaseE'
- ;; ld: /gnu/store/bxapb1f1l8frjpbjckk3zdxhmcig3xzk-googletest-1.10.0/lib/libgmock.so:
+ ;; ld: /gnu/store/...-googletest-1.10.0/lib/libgmock.so:
;; error adding symbols: DSO missing from command line
;; collect2: error: ld returned 1 exit status
"-DCMAKE_EXE_LINKER_FLAGS=-lgtest -lpthread -lgmock")
diff --git a/gnu/packages/cran.scm b/gnu/packages/cran.scm
index 6ca47c8755..ee4ad98d44 100644
--- a/gnu/packages/cran.scm
+++ b/gnu/packages/cran.scm