diff options
28 files changed, 753 insertions, 202 deletions
diff --git a/doc/guix.texi b/doc/guix.texi index b14c8e0020..8a781f5ec7 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -1051,13 +1051,11 @@ name, and they will be scheduled on matching build machines. @end table @end deftp -The @code{guile} command must be in the search path on the build -machines. In addition, the Guix modules must be in -@code{$GUILE_LOAD_PATH} on the build machine---you can check whether -this is the case by running: +The @command{guix} command must be in the search path on the build +machines. You can check whether this is the case by running: @example -ssh build-machine guile -c "'(use-modules (guix config))'" +ssh build-machine guix repl --version @end example There is one last thing to do once @file{machines.scm} is in place. As @@ -7392,6 +7390,22 @@ are many packages, though, for which it lacks a method to determine whether a new upstream release is available. However, the mechanism is extensible, so feel free to get in touch with us to add a new method! +@table @code + +@item --recursive +Consider the packages specified, and all the packages upon which they depend. + +@example +$ guix refresh --recursive coreutils +gnu/packages/acl.scm:35:2: warning: no updater for acl +gnu/packages/m4.scm:30:12: info: 1.4.18 is already the latest version of m4 +gnu/packages/xml.scm:68:2: warning: no updater for expat +gnu/packages/multiprecision.scm:40:12: info: 6.1.2 is already the latest version of gmp +@dots{} +@end example + +@end table + Sometimes the upstream name differs from the package name used in Guix, and @command{guix refresh} needs a little help. Most updaters honor the @code{upstream-name} property in package definitions, which can be used @@ -7565,6 +7579,22 @@ hop@@2.4.0 geiser@@0.4 notmuch@@0.18 mu@@0.9.9.5 cflow@@1.4 idutils@@4.6 @dots{} The command above lists a set of packages that could be built to check for compatibility with an upgraded @code{flex} package. +@table @code + +@item --list-transitive +List all the packages which one or more packages depend upon. + +@example +$ guix refresh --list-transitive flex +flex@@2.6.4 depends on the following 25 packages: perl@@5.28.0 help2man@@1.47.6 +bison@@3.0.5 indent@@2.2.10 tar@@1.30 gzip@@1.9 bzip2@@1.0.6 xz@@5.2.4 file@@5.33 @dots{} +@end example + +@end table + +The command above lists a set of packages which, when changed, would cause +@code{flex} to be rebuilt. + The following options can be used to customize GnuPG operation: @table @code @@ -7660,12 +7690,14 @@ Identify inputs that should most likely be native inputs. @item source @itemx home-page @itemx mirror-url +@itemx github-url @itemx source-file-name Probe @code{home-page} and @code{source} URLs and report those that are -invalid. Suggest a @code{mirror://} URL when applicable. Check that -the source file name is meaningful, e.g.@: is not -just a version number or ``git-checkout'', without a declared -@code{file-name} (@pxref{origin Reference}). +invalid. Suggest a @code{mirror://} URL when applicable. If the +@code{source} URL redirects to a GitHub URL, recommend usage of the GitHub +URL. Check that the source file name is meaningful, e.g.@: is not just a +version number or ``git-checkout'', without a declared @code{file-name} +(@pxref{origin Reference}). @item cve @cindex security vulnerabilities @@ -16332,6 +16364,37 @@ Configuration snippet added as-is to the BitlBee configuration file. @end table @end deftp +@subsubheading Quassel Service + +@cindex IRC (Internet Relay Chat) +@url{https://quassel-irc.org/,Quassel} is a distributed IRC client, +meaning that one or more clients can attach to and detach from the +central core. + +@defvr {Scheme Variable} quassel-service-type +This is the service type for the @url{https://quassel-irc.org/,Quassel} +IRC backend daemon. Its value is a @code{quassel-configuration} +(see below). +@end defvr + +@deftp {Data Type} quassel-configuration +This is the configuration for Quassel, with the following fields: + +@table @asis +@item @code{quassel} (default: @code{quassel}) +The Quassel package to use. + +@item @code{interface} (default: @code{"::,0.0.0.0"}) +@item @code{port} (default: @code{4242}) +Listen on the network interface(s) corresponding to the IPv4 or IPv6 +interfaces specified in the comma delimited @var{interface}, on +@var{port}. + +@item @code{loglevel} (default: @code{"Info"}) +The level of logging desired. Accepted values are Debug, Info, Warning +and Error. +@end table +@end deftp @node Telephony Services @subsubsection Telephony Services diff --git a/gnu/local.mk b/gnu/local.mk index 62407351a0..b55382cc5d 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -689,6 +689,7 @@ dist_patch_DATA = \ %D%/packages/patches/fcgi-2.4.0-poll.patch \ %D%/packages/patches/fifo-map-fix-flags-for-gcc.patch \ %D%/packages/patches/fifo-map-remove-catch.hpp.patch \ + %D%/packages/patches/file-CVE-2018-10360.patch \ %D%/packages/patches/findutils-gnulib-libio.patch \ %D%/packages/patches/findutils-localstatedir.patch \ %D%/packages/patches/findutils-makedev.patch \ diff --git a/gnu/packages/audio.scm b/gnu/packages/audio.scm index 7f72531664..0b24806d92 100644 --- a/gnu/packages/audio.scm +++ b/gnu/packages/audio.scm @@ -17,6 +17,7 @@ ;;; Copyright © 2018 Marius Bakke <mbakke@fastmail.com> ;;; Copyright © 2018 Thorsten Wilms <t_w_@freenet.de> ;;; Copyright © 2018 Eric Bavier <bavier@member.fsf.org> +;;; Copyright © 2018 Brendan Tildesley <brendan.tildesley@openmailbox.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -74,6 +75,7 @@ #:use-module (gnu packages qt) #:use-module (gnu packages libbsd) #:use-module (gnu packages linux) + #:use-module (gnu packages libusb) #:use-module (gnu packages llvm) #:use-module (gnu packages mp3) ;taglib #:use-module (gnu packages perl) @@ -229,57 +231,79 @@ namespace ARDOUR { const char* revision = \"" version "\" ; }")) (arguments `(#:configure-flags '("--cxx11" ; required by gtkmm "--no-phone-home" ; don't contact ardour.org - "--freedesktop" ; install .desktop file + "--freedesktop" ; build .desktop file "--test") ; build unit tests #:phases (modify-phases %standard-phases - (add-after - 'unpack 'set-rpath-in-LDFLAGS - ,(ardour-rpath-phase (version-major version)))) + (add-after 'unpack 'set-rpath-in-LDFLAGS + ,(ardour-rpath-phase (version-major version))) + (add-after 'install 'install-freedesktop-files + (lambda* (#:key outputs #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (share (string-append out "/share")) + (ver ,(version-major version))) + (for-each + (lambda (size) + (let ((dir (string-append share "/icons/hicolor/" + size "x" size "/apps"))) + (mkdir-p dir) + (copy-file + (string-append "gtk2_ardour/resources/Ardour-icon_" + size "px.png") + (string-append dir "/ardour" ver ".png")))) + '("16" "22" "32" "48" "256")) + (install-file (string-append "build/gtk2_ardour/ardour" + ver ".desktop") + (string-append share "/applications/")) + (install-file (string-append "build/gtk2_ardour/ardour" + ver ".appdata.xml") + (string-append share "/appdata/"))) + #t))) #:test-target "test" #:python ,python-2)) (inputs `(("alsa-lib" ,alsa-lib) + ("atkmm" ,atkmm) ("aubio" ,aubio) - ("lrdf" ,lrdf) ("boost" ,boost) - ("atkmm" ,atkmm) ("cairomm" ,cairomm) + ("curl" ,curl) ("eudev" ,eudev) - ("gtkmm" ,gtkmm-2) + ("fftw" ,fftw) + ("fftwf" ,fftwf) + ("flac" ,flac) ("glibmm" ,glibmm) + ("gtkmm" ,gtkmm-2) + ("jack" ,jack-1) + ("libarchive" ,libarchive) ("libart-lgpl" ,libart-lgpl) ("libgnomecanvasmm" ,libgnomecanvasmm) - ("pangomm" ,pangomm) ("liblo" ,liblo) - ("libsndfile" ,libsndfile) - ("libsamplerate" ,libsamplerate) - ("libxml2" ,libxml2) ("libogg" ,libogg) + ("libsamplerate" ,libsamplerate) + ("libsndfile" ,libsndfile) + ("libusb" ,libusb) ("libvorbis" ,libvorbis) - ("flac" ,flac) + ("libxml2" ,libxml2) + ("lilv" ,lilv) + ("lrdf" ,lrdf) ("lv2" ,lv2) - ("vamp" ,vamp) - ("curl" ,curl) - ("fftw" ,fftw) - ("fftwf" ,fftwf) - ("jack" ,jack-1) + ("pangomm" ,pangomm) + ("python-rdflib" ,python-rdflib) + ("readline" ,readline) + ("redland" ,redland) + ("rubberband" ,rubberband) ("serd" ,serd) ("sord" ,sord) ("sratom" ,sratom) ("suil" ,suil) - ("lilv" ,lilv) - ("readline" ,readline) - ("redland" ,redland) - ("rubberband" ,rubberband) - ("libarchive" ,libarchive) ("taglib" ,taglib) - ("python-rdflib" ,python-rdflib))) + ("vamp" ,vamp))) (native-inputs - `(("perl" ,perl) - ("cppunit" ,cppunit) - ("itstool" ,itstool) + `(("cppunit" ,cppunit) ("gettext" ,gettext-minimal) + ("itstool" ,itstool) + ("perl" ,perl) ("pkg-config" ,pkg-config))) (home-page "http://ardour.org") (synopsis "Digital audio workstation") diff --git a/gnu/packages/dictionaries.scm b/gnu/packages/dictionaries.scm index 039ec45965..9e06ac7124 100644 --- a/gnu/packages/dictionaries.scm +++ b/gnu/packages/dictionaries.scm @@ -247,21 +247,41 @@ and a Python library.") (define-public translate-shell (package (name "translate-shell") - (version "0.9.6.8") + (version "0.9.6.9") (source (origin - (method url-fetch) - (uri (string-append "https://github.com/soimort/" name "/archive/v" - version ".tar.gz")) + (method git-fetch) + (uri (git-reference + (url"https://github.com/soimort/translate-shell.git") + (commit (string-append "v" version)))) + (file-name (git-file-name name version)) (sha256 (base32 - "17yc2kwk8957wwxyih0jmsai720ai2yqyvmrqrglcncqg6zdbz9w")) - (file-name (string-append name "-" version ".tar.gz")))) + "1xyf0vdxmbgqcgsr1gvgwh1q4fh080h68radkim6pfcwzffliszm")))) (build-system gnu-build-system) (arguments `(#:phases (modify-phases %standard-phases (delete 'configure) ; no configure phase + (add-after 'unpack 'remove-unnecessary-file + ;; This file gets generated during the build phase. + (lambda _ + (delete-file "translate") + #t)) + (add-after 'install 'wrap-binary + (lambda* (#:key inputs outputs #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (bin (string-append out "/bin/trans")) + (curl (assoc-ref inputs "curl")) + (fribidi (assoc-ref inputs "fribidi")) + (rlwrap (assoc-ref inputs "rlwrap"))) + (wrap-program bin + `("PATH" ":" prefix + (,(string-append out "/bin:" + curl "/bin:" + fribidi "/bin:" + rlwrap "/bin"))))) + #t)) (add-after 'install 'emacs-install (lambda* (#:key inputs outputs #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) @@ -277,7 +297,7 @@ and a Python library.") (guix build emacs-utils) (guix build utils)) #:test-target "test")) - (propagated-inputs + (inputs `(("curl" ,curl) ("fribidi" ,fribidi) ("rlwrap" ,rlwrap))) diff --git a/gnu/packages/education.scm b/gnu/packages/education.scm index 567dfce58d..ef97d58a84 100644 --- a/gnu/packages/education.scm +++ b/gnu/packages/education.scm @@ -41,6 +41,7 @@ #:use-module (gnu packages qt) #:use-module (gnu packages sdl) #:use-module (gnu packages texinfo) + #:use-module (gnu packages xorg) #:use-module (gnu packages xml) #:use-module ((guix licenses) #:prefix license:) #:use-module (guix packages) @@ -115,7 +116,7 @@ of categories with some of the activities available in that category. (define-public gcompris-qt (package (name "gcompris-qt") - (version "0.91") + (version "0.95") (source (origin (method url-fetch) @@ -124,17 +125,17 @@ of categories with some of the activities available in that category. version ".tar.xz")) (sha256 (base32 - "09h098w9q79hnzla1pcpqlnnr6dbafm4q6zmdp7wlk11ym8n9kvg")))) + "1aaijjx2b7k1cyx59jhs64hlp1sppw1faa81qxl5lxc79vifrlrl")))) (build-system cmake-build-system) (arguments `(#:phases (modify-phases %standard-phases - (add-after 'unpack 'patch-for-qt5.11 - (lambda _ - (substitute* "src/core/CMakeLists.txt" - (("qt5_use_modules") "target_link_libraries") - (("Qml Quick Gui Multimedia Network XmlPatterns Svg Xml Sensors Core") - "Qt5::Qml Qt5::Quick Qt5::Gui Qt5::Multimedia Qt5::Core Qt5::Svg Qt5::Xml Qt5::XmlPatterns Qt5::Sensors")) + (add-before 'check 'start-xorg-server + (lambda* (#:key inputs #:allow-other-keys) + ;; The test suite requires a running X server. + (system (string-append (assoc-ref inputs "xorg-server") + "/bin/Xvfb :1 &")) + (setenv "DISPLAY" ":1") #t)) (add-after 'install 'wrap-executable (lambda* (#:key inputs outputs #:allow-other-keys) @@ -152,13 +153,14 @@ of categories with some of the activities available in that category. '("qtdeclarative" "qtgraphicaleffects" "qtmultimedia" "qtquickcontrols")))) #t)))) - #:configure-flags (list "-DQML_BOX2D_MODULE=disabled") - #:tests? #f)) ; no test target + #:configure-flags (list "-DQML_BOX2D_MODULE=disabled" + "-DBUILD_TESTING=TRUE"))) (native-inputs `(("extra-cmake-modules" ,extra-cmake-modules) ("gettext" ,gettext-minimal) ("perl" ,perl) - ("qttools" ,qttools))) + ("qttools" ,qttools) + ("xorg-server" ,xorg-server))) (inputs `(("python-2" ,python-2) ("qtbase" ,qtbase) diff --git a/gnu/packages/file.scm b/gnu/packages/file.scm index 78f0360c2e..4518c8d3dc 100644 --- a/gnu/packages/file.scm +++ b/gnu/packages/file.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2014, 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2016, 2017 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2018 Tobias Geerinckx-Rice <me@tobias.gr> +;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il> ;;; ;;; This file is part of GNU Guix. ;;; @@ -30,6 +31,7 @@ (package (name "file") (version "5.33") + (replacement file/fixed) (source (origin (method url-fetch) (uri (string-append "ftp://ftp.astron.com/pub/file/file-" @@ -51,3 +53,10 @@ extensions to tell you the type of a file, but looks at the actual contents of the file. This package provides the libmagic library.") (license bsd-2) (home-page "https://www.darwinsys.com/file/"))) + +(define file/fixed + (package + (inherit file) + (source + (origin (inherit (package-source file)) + (patches (search-patches "file-CVE-2018-10360.patch")))))) diff --git a/gnu/packages/fonts.scm b/gnu/packages/fonts.scm index b0cb78c5cb..88315008bd 100644 --- a/gnu/packages/fonts.scm +++ b/gnu/packages/fonts.scm @@ -22,6 +22,7 @@ ;;; Copyright © 2017, 2018 Arun Isaac <arunisaac@systemreboot.net> ;;; Copyright © 2017 Mohammed Sadiq <sadiq@sadiqpk.org> ;;; Copyright © 2018 Charlie Ritter <chewzerita@posteo.net> +;;; Copyright © 2018 Gabriel Hondet <gabrielhondet@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -1351,3 +1352,24 @@ reproduction and display environments. This package provides only TrueType files (TTF).") (home-page "https://software.sil.org/charis/") (license license:silofl1.1))) + +(define-public font-mononoki + (package + (name "font-mononoki") + (version "1.2") + (source (origin + (method git-fetch) + (uri (git-reference + (url "https://github.com/madmalik/mononoki/") + (commit version))) + (sha256 + (base32 + "1rkzyxn30rn8qv2h2xz324j7q15hzg2lci8790a7cdl1dfgic4xi")) + (file-name (git-file-name name version)))) + (build-system font-build-system) + (synopsis "Font for programming and code review") + (description + "Mononoki is a typeface by Matthias Tellen, created to enhance code +formatting.") + (home-page "https://madmalik.github.io/mononoki/") + (license license:silofl1.1))) diff --git a/gnu/packages/gnupg.scm b/gnu/packages/gnupg.scm index 53fdc8200c..951fc05fa2 100644 --- a/gnu/packages/gnupg.scm +++ b/gnu/packages/gnupg.scm @@ -471,16 +471,23 @@ interface (FFI) of Guile.") (define-public python-gpg (package (name "python-gpg") - (version "1.8.0") + (version "1.10.0") (source (origin (method url-fetch) (uri (pypi-uri "gpg" version)) (sha256 (base32 - "1x74i6q713c0bckls7rdm8kgsmllf9qvy9x62jghszlhgjkyh9nd")))) + "1ji3ynhp36m1ccx7bmaq75dhij9frpn19v9mpi4aajn8csl194il")))) (build-system python-build-system) (arguments - '(#:tests? #f)) ; No test suite. + '(#:phases + (modify-phases %standard-phases + (add-before 'build 'set-environment + (lambda _ + (substitute* "setup.py" + (("cc") (which "gcc"))) + #t))) + #:tests? #f)) ; No test suite. (inputs `(("gpgme" ,gpgme))) (native-inputs diff --git a/gnu/packages/kde-frameworks.scm b/gnu/packages/kde-frameworks.scm index f5a084a7e8..988bf44c3d 100644 --- a/gnu/packages/kde-frameworks.scm +++ b/gnu/packages/kde-frameworks.scm @@ -207,33 +207,6 @@ Phonon-GStreamer is a backend based on the GStreamer multimedia library.") ;; license: source files mention "either version 2.1 or 3" (license (list license:lgpl2.1 license:lgpl3)))) -(define-public gpgmepp - (package - (name "gpgmepp") - (version "16.08.2") - (source (origin - (method url-fetch) - (uri (string-append - "mirror://kde/stable/applications" - "/" version "/src/" - name "-" version ".tar.xz")) - (sha256 - (base32 - "0828qlhdi1i26n2xgyb01c0q77m6jlppbxv6mprryxq0ma88940a")))) - (build-system cmake-build-system) - (native-inputs - `(("extra-cmake-modules" ,extra-cmake-modules))) - (propagated-inputs - `(("boost" ,boost) - ("gpgme" ,gpgme))) - (inputs - `(("qtbase" ,qtbase))) - (home-page "https://community.kde.org/Frameworks") - (synopsis "C++ bindings/wrapper for gpgme") - (description "C++ bindings/wrapper for gpgme.") - (license license:lgpl2.1+) - (properties `((superseded . ,gpgme))))) - (define-public kpmcore (package (name "kpmcore") @@ -2003,7 +1976,8 @@ gallons).") ;; This test fails on i686 and aarch64 (lambda _ (substitute* "autotests/unit/file/CMakeLists.txt" - (("metadatamovertest") "")) + (("^\\s*ecm_add_test\\(.* TEST_NAME metadatamovertest .*" line) + (string-append "# " line))) #t)) (replace 'check (lambda _ diff --git a/gnu/packages/llvm.scm b/gnu/packages/llvm.scm index ec79bcc95c..2a3754b931 100644 --- a/gnu/packages/llvm.scm +++ b/gnu/packages/llvm.scm @@ -97,10 +97,10 @@ of programming tools as well as libraries with equivalent functionality.") ;; TODO: Build Mesa with LLVM 7 in the next staging cycle. ;; TODO: Make LLVM 7 the default LLVM once Clang is also upgraded. -(define-public llvm-7.0.0 +(define-public llvm-7.0.1 (package (inherit llvm) (name "llvm") - (version "7.0.0") + (version "7.0.1") (source (origin (method url-fetch) @@ -108,7 +108,7 @@ of programming tools as well as libraries with equivalent functionality.") version "/llvm-" version ".src.tar.xz")) (sha256 (base32 - "08p27wv1pr9ql2zc3f3qkkymci46q7myvh8r5ijippnbwr2gihcb")))))) + "16s196wqzdw4pmri15hadzqgdi926zln3an2viwyq0kini6zr3d3")))))) (define* (clang-runtime-from-llvm llvm hash #:optional (patches '())) diff --git a/gnu/packages/ocaml.scm b/gnu/packages/ocaml.scm index 3b1ddcb5b6..603db34dbd 100644 --- a/gnu/packages/ocaml.scm +++ b/gnu/packages/ocaml.scm @@ -10,6 +10,7 @@ ;;; Copyright © 2017 Ben Woodcroft <donttrustben@gmail.com> ;;; Copyright © 2017, 2018 Tobias Geerinckx-Rice <me@tobias.gr> ;;; Copyright © 2018 Peter Kreye <kreyepr@gmail.com> +;;; Copyright © 2018 Gabriel Hondet <gabrielhondet@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -4989,3 +4990,57 @@ provides BigN, BigZ, BigQ that used to be part of Coq standard library.") simplifying the proofs of inequalities on expressions of real numbers for the Coq proof assistant.") (license license:cecill-c))) + +(define-public dedukti + (package + (name "dedukti") + (version "2.6.0") + (home-page "https://deducteam.github.io/") + (source + (origin + (method git-fetch) + (uri (git-reference + (url "https://github.com/deducteam/dedukti.git") + (commit (string-append "v" version)))) + (file-name (git-file-name name version)) + (sha256 + (base32 + "0frl3diff033i4fmq304b8wbsdnc9mvlhmwd7a3zd699ng2lzbxb")))) + (inputs + `(("menhir" ,ocaml-menhir))) + (native-inputs + `(("ocamlbuild" ,ocamlbuild))) + (build-system ocaml-build-system) + (arguments + `(#:phases + (modify-phases %standard-phases + (delete 'configure) + (replace 'build + (lambda _ + (invoke "make") + #t)) + (replace 'check + (lambda _ + (invoke "make" "tests") + #t)) + (add-before 'install 'set-binpath + ;; Change binary path in the makefile + (lambda _ + (let ((out (assoc-ref %outputs "out"))) + (substitute* "GNUmakefile" + (("BINDIR = (.*)$") + (string-append "BINDIR = " out "/bin")))) + #t)) + (replace 'install + (lambda _ + (invoke "make" "install") + #t))))) + (synopsis "Proof-checker for the λΠ-calculus modulo theory, an extension of +the λ-calculus") + (description "Dedukti is a proof-checker for the λΠ-calculus modulo +theory. The λΠ-calculus is an extension of the simply typed λ-calculus with +dependent types. The λΠ-calculus modulo theory is itself an extension of the +λΠ-calculus where the context contains variable declaration as well as rewrite +rules. This system is not designed to develop proofs, but to check proofs +developed in other systems. In particular, it enjoys a minimalistic syntax.") + (license license:cecill-c))) diff --git a/gnu/packages/package-management.scm b/gnu/packages/package-management.scm index 3598ac4e67..9bb71dc80f 100644 --- a/gnu/packages/package-management.scm +++ b/gnu/packages/package-management.scm @@ -105,8 +105,8 @@ ;; Note: the 'update-guix-package.scm' script expects this definition to ;; start precisely like this. (let ((version "0.16.0") - (commit "bdf860c2e99077d431da0cc1db4fc14db2a35d31") - (revision 6)) + (commit "6f1e0bb79266f34b50b09200b9280a641b8aa7c8") + (revision 7)) (package (name "guix") @@ -122,7 +122,7 @@ (commit commit))) (sha256 (base32 - "0876y2pjcrwb3ynxqlpkn3pxx2iil8hrzdadh23jd6jbhvm087q1")) + "0xk4ki5zsliwknxc9a3lvpjzpckz8nx4dz55xmw9sydq5z5mmy50")) (file-name (string-append "guix-" version "-checkout")))) (build-system gnu-build-system) (arguments diff --git a/gnu/packages/parallel.scm b/gnu/packages/parallel.scm index df8ac180b3..25d3c0737c 100644 --- a/gnu/packages/parallel.scm +++ b/gnu/packages/parallel.scm @@ -48,7 +48,7 @@ (define-public parallel (package (name "parallel") - (version "20181122") + (version "20181222") (source (origin (method url-fetch) @@ -56,7 +56,7 @@ version ".tar.bz2")) (sha256 (base32 - "1mcqymf6vg8jhnjv71sswcz5xrwpq2h2ishi8m1hz8rwhc65h1ig")))) + "0sd39nzgff3rpyzfwkffb5yxbdm5r6amrkslbgpjlrcrymy9z305")))) (build-system gnu-build-system) (arguments `(#:phases diff --git a/gnu/packages/patches/file-CVE-2018-10360.patch b/gnu/packages/patches/file-CVE-2018-10360.patch new file mode 100644 index 0000000000..9285611c04 --- /dev/null +++ b/gnu/packages/patches/file-CVE-2018-10360.patch @@ -0,0 +1,27 @@ +https://github.com/file/file/commit/a642587a9c9e2dd7feacdf513c3643ce26ad3c22.patch +The leading part of the patch starting at line 27 was trimmed off. +This patch should be OK to drop with file@5.35. + +From a642587a9c9e2dd7feacdf513c3643ce26ad3c22 Mon Sep 17 00:00:00 2001 +From: Christos Zoulas <christos@zoulas.com> +Date: Sat, 9 Jun 2018 16:00:06 +0000 +Subject: [PATCH] Avoid reading past the end of buffer (Rui Reis) + +--- + src/readelf.c | 5 +++-- + 1 file changed, 3 insertions(+), 2 deletions(-) + +diff --git a/src/readelf.c b/src/readelf.c +index 79c83f9f5..1f41b4611 100644 +--- a/src/readelf.c ++++ b/src/readelf.c +@@ -842,7 +842,8 @@ do_core_note(struct magic_set *ms, unsigned char *nbuf, uint32_t type, + + cname = (unsigned char *) + &nbuf[doff + prpsoffsets(i)]; +- for (cp = cname; *cp && isprint(*cp); cp++) ++ for (cp = cname; cp < nbuf + size && *cp ++ && isprint(*cp); cp++) + continue; + /* + * Linux apparently appends a space at the end diff --git a/gnu/packages/photo.scm b/gnu/packages/photo.scm index 7b40c2361c..07047f4cf3 100644 --- a/gnu/packages/photo.scm +++ b/gnu/packages/photo.scm @@ -353,7 +353,7 @@ photographic equipment.") (define-public darktable (package (name "darktable") - (version "2.4.4") + (version "2.6.0") (source (origin (method url-fetch) (uri (string-append @@ -362,7 +362,7 @@ photographic equipment.") version "/darktable-" version ".tar.xz")) (sha256 (base32 - "0kdhmiw4wxk2w9v2hms9yk8nl4ymdshnqyj0l07nivzzr6w20hwn")))) + "0y04cx0a0rwdclmn16f5y0z2vnm7yxly291gzjgdhcn59a77sga8")))) (build-system cmake-build-system) (arguments `(#:tests? #f ; There are no tests. diff --git a/gnu/packages/python-web.scm b/gnu/packages/python-web.scm index a5b4b7578d..8412325377 100644 --- a/gnu/packages/python-web.scm +++ b/gnu/packages/python-web.scm @@ -509,27 +509,28 @@ is Python’s.") (define-public python-openid (package (name "python-openid") - (version "3.0.10") + (version "3.1.0") (source (origin (method url-fetch) (uri (pypi-uri "python3-openid" version)) (sha256 (base32 - "1x3nh3fycqfn43jp5j5pb4q4y2jxp4mdka4absaa3bc0078qd758")))) + "00l5hrjh19740w00b3fnsqldnla41wbr2rics09dl4kyd1fkd3b2")))) (build-system python-build-system) (arguments `(#:phases (modify-phases %standard-phases (replace 'check (lambda _ - (invoke "./admin/runtests") - #t))))) + (invoke "coverage" "run" "-m" + "unittest" "openid.test.test_suite")))))) (properties `((python2-variant . ,(delay python2-openid)))) (propagated-inputs `(("python-defusedxml" ,python-defusedxml))) (native-inputs - `(("python-psycopg2" ,python-psycopg2) + `(("python-coverage" ,python-coverage) + ("python-psycopg2" ,python-psycopg2) ("python-django" ,python-django))) (home-page "https://github.com/necaris/python3-openid") (synopsis "OpenID support for servers and consumers") diff --git a/gnu/packages/python.scm b/gnu/packages/python.scm index bb4c5ab760..9ef0654cb8 100644 --- a/gnu/packages/python.scm +++ b/gnu/packages/python.scm @@ -12637,14 +12637,14 @@ validating Swagger API specifications.") (define-public python-apache-libcloud (package (name "python-apache-libcloud") - (version "2.3.0") + (version "2.4.0") (source (origin (method url-fetch) (uri (pypi-uri "apache-libcloud" version)) (sha256 - (base32 - "15xg79ad4g2xrk081ylvj41k5hmg9hl1xvbmb5hd0fqn08wfwbhf")))) + (base32 + "0daj3mkzw79v5zin2r1s2wkrz1hplfc16bwj4ss68i5qjq4l2p0j")))) (build-system python-build-system) (arguments `(#:phases diff --git a/gnu/packages/wine.scm b/gnu/packages/wine.scm index 802b3dd38f..f56699f8c9 100644 --- a/gnu/packages/wine.scm +++ b/gnu/packages/wine.scm @@ -225,7 +225,7 @@ integrate Windows applications into your desktop.") (define-public wine-staging-patchset-data (package (name "wine-staging-patchset-data") - (version "3.21") + (version "4.0-rc3") (source (origin (method git-fetch) @@ -235,7 +235,7 @@ integrate Windows applications into your desktop.") (file-name (git-file-name name version)) (sha256 (base32 - "1bxryvqw5rvhcx8vjl714jaj0rjsrh95kh3sn499rrljc3c8qsbl")))) + "1yx758mv605w2g7f9aj4xf09p8q5dvbf6b9h1kdvsyhm8bkrgx66")))) (build-system trivial-build-system) (native-inputs `(("bash" ,bash) @@ -276,12 +276,12 @@ integrate Windows applications into your desktop.") (method url-fetch) (uri (string-append "https://dl.winehq.org/wine/source/" - (version-major version) ".x" + (version-major version) ".0" "/wine-" version ".tar.xz")) (file-name (string-append name "-" version ".tar.xz")) (sha256 (base32 - "1h70wb7kysbzv36i3fblyiihvalwhy6sj4s2a8nf21nz2mhc0k58")))) + "176cdnznbk3pikh87j5q4cjb7rky5dxikf1nr0mp8a9cycycxr7w")))) (inputs `(("autoconf" ,autoconf) ; for autoreconf ("gtk+" ,gtk+) ("libva" ,libva) diff --git a/gnu/packages/wm.scm b/gnu/packages/wm.scm index 2e211e3892..a761bce235 100644 --- a/gnu/packages/wm.scm +++ b/gnu/packages/wm.scm @@ -76,6 +76,7 @@ #:use-module (gnu packages lua) #:use-module (gnu packages linux) #:use-module (gnu packages suckless) + #:use-module (gnu packages mpd) #:use-module (guix download) #:use-module (guix git-download)) @@ -1051,3 +1052,45 @@ its size @item Display preview images in a tiled icon layout @end itemize") (license license:gpl2+))) + +(define-public polybar + (package + (name "polybar") + (version "3.3.0") + (source + (origin + (method url-fetch) + (uri (string-append "https://github.com/jaagr/polybar/releases/" + "download/" version "/polybar.tar")) + (sha256 + (base32 "0sjh3xmf11g09spi88zj7xsc3a3vv78kixab6n5i7436py7xwzb4")) + (file-name (string-append name "-" version ".tar")))) + (build-system cmake-build-system) + (arguments + ;; Test is disabled because it requires downloading googletest from the + ;; Internet. + '(#:tests? #f)) + (inputs + `(("alsa-lib" ,alsa-lib) + ("cairo" ,cairo) + ("i3-wm" ,i3-wm) + ("libmpdclient" ,libmpdclient) + ("libnl" ,libnl) + ("libxcb" ,libxcb) + ("pulseaudio" ,pulseaudio) + ("xcb-proto" ,xcb-proto) + ("xcb-util" ,xcb-util) + ("xcb-util-cursor" ,xcb-util-cursor) + ("xcb-util-image" ,xcb-util-image) + ("xcb-util-wm" ,xcb-util-wm) + ("xcb-util-xrm" ,xcb-util-xrm))) + (native-inputs + `(("pkg-config" ,pkg-config) + ("python-2" ,python-2) ; lib/xpp depends on python 2 + ("python" ,python))) ; xcb-proto depends on python 3 + (home-page "https://polybar.github.io/") + (synopsis "Fast and easy-to-use status bar") + (description "Polybar aims to help users build beautiful and highly +customizable status bars for their desktop environment. It has built-in +functionality to display information about the most commonly used services.") + (license license:expat))) diff --git a/gnu/services/messaging.scm b/gnu/services/messaging.scm index 1108006411..92f86a1b83 100644 --- a/gnu/services/messaging.scm +++ b/gnu/services/messaging.scm @@ -22,6 +22,8 @@ (define-module (gnu services messaging) #:use-module (gnu packages messaging) #:use-module (gnu packages admin) + #:use-module (gnu packages irc) + #:use-module (gnu packages tls) #:use-module (gnu services) #:use-module (gnu services shepherd) #:use-module (gnu services configuration) @@ -50,7 +52,10 @@ bitlbee-configuration bitlbee-configuration? bitlbee-service - bitlbee-service-type)) + bitlbee-service-type + + quassel-configuration + quassel-service-type)) ;;; Commentary: ;;; @@ -895,3 +900,86 @@ configuration file." (bitlbee bitlbee) (interface interface) (port port) (extra-settings extra-settings)))) + + +;;; +;;; Quassel. +;;; + +(define-record-type* <quassel-configuration> + quassel-configuration make-quassel-configuration + quassel-configuration? + (quassel quassel-configuration-quassel + (default quassel)) + (interface quassel-configuration-interface + (default "::,0.0.0.0")) + (port quassel-configuration-port + (default 4242)) + (loglevel quassel-configuration-loglevel + (default "Info"))) + +(define quassel-shepherd-service + (match-lambda + (($ <quassel-configuration> quassel interface port loglevel) + (with-imported-modules (source-module-closure + '((gnu build shepherd) + (gnu system file-systems))) + (list (shepherd-service + (provision '(quassel)) + (requirement '(user-processes networking)) + (modules '((gnu build shepherd) + (gnu system file-systems))) + (start #~(make-forkexec-constructor/container + (list #$(file-append quassel "/bin/quasselcore") + "--configdir=/var/lib/quassel" + "--logfile=/var/log/quassel/core.log" + (string-append "--loglevel=" #$loglevel) + (string-append "--port=" (number->string #$port)) + (string-append "--listen=" #$interface)) + #:mappings (list (file-system-mapping + (source "/var/lib/quassel") + (target source) + (writable? #t)) + (file-system-mapping + (source "/var/log/quassel") + (target source) + (writable? #t))))) + (stop #~(make-kill-destructor)))))))) + +(define %quassel-account + (list (user-group (name "quassel") (system? #t)) + (user-account + (name "quasselcore") + (group "quassel") + (system? #t) + (comment "Quassel daemon user") + (home-directory "/var/lib/quassel") + (shell (file-append shadow "/sbin/nologin"))))) + +(define %quassel-activation + #~(begin + (use-modules (guix build utils)) + (mkdir-p "/var/lib/quassel") + (mkdir-p "/var/log/quassel") + (let ((cert "/var/lib/quassel/quasselCert.pem")) + (unless (file-exists? cert) + (invoke #$(file-append openssl "/bin/openssl") + "req" "-x509" "-nodes" "-batch" "-days" "680" "-newkey" + "rsa" "-keyout" cert "-out" cert))))) + +(define quassel-service-type + (service-type (name 'quassel) + (extensions + (list (service-extension shepherd-root-service-type + quassel-shepherd-service) + (service-extension profile-service-type + (compose list quassel-configuration-quassel)) + (service-extension account-service-type + (const %quassel-account)) + (service-extension activation-service-type + (const %quassel-activation)))) + (default-value (quassel-configuration)) + (description + "Run @url{https://quassel-irc.org/,quasselcore}, the backend +for the distributed IRC client quassel, which allows you to connect from +multiple machines simultaneously."))) diff --git a/gnu/system/examples/vm-image.tmpl b/gnu/system/examples/vm-image.tmpl index 36e272722d..f149f67113 100644 --- a/gnu/system/examples/vm-image.tmpl +++ b/gnu/system/examples/vm-image.tmpl @@ -24,6 +24,8 @@ partprobe, and then 2) resizing the filesystem with resize2fs.\n")) (timezone "Etc/UTC") (locale "en_US.utf8") +(firmware '()) + ;; Assuming /dev/sdX is the target hard disk, and "my-root" is ;; the label of the target root file system. (bootloader (bootloader-configuration diff --git a/gnu/tests/messaging.scm b/gnu/tests/messaging.scm index 36afb987af..176e3d08cb 100644 --- a/gnu/tests/messaging.scm +++ b/gnu/tests/messaging.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org> ;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il> ;;; ;;; This file is part of GNU Guix. ;;; @@ -29,7 +30,8 @@ #:use-module (guix store) #:use-module (guix modules) #:export (%test-prosody - %test-bitlbee)) + %test-bitlbee + %test-quassel)) (define (run-xmpp-test name xmpp-service pid-file create-account) "Run a test of an OS running XMPP-SERVICE, which writes its PID to PID-FILE." @@ -239,3 +241,53 @@ (name "bitlbee") (description "Connect to a BitlBee IRC server.") (value (run-bitlbee-test)))) + +(define (run-quassel-test) + (define os + (marionette-operating-system + (simple-operating-system (service dhcp-client-service-type) + (service quassel-service-type)) + #:imported-modules (source-module-closure + '((gnu services herd))))) + + (define vm + (virtual-machine + (operating-system os) + (port-forwardings `((4242 . 4242))))) + + (define test + (with-imported-modules '((gnu build marionette)) + #~(begin + (use-modules (srfi srfi-64) + (gnu build marionette)) + + (define marionette + (make-marionette (list #$vm))) + + (mkdir #$output) + (chdir #$output) + + (test-begin "quassel") + + (test-assert "service started" + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (start-service 'quassel)) + marionette)) + + (test-assert "certificate file" + (marionette-eval + '(file-exists? "/var/lib/quassel/quasselCert.pem") + marionette)) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + + (gexp->derivation "quassel-test" test)) + +(define %test-quassel + (system-test + (name "quassel") + (description "Connect to a quassel IRC server.") + (value (run-quassel-test)))) diff --git a/guix/inferior.scm b/guix/inferior.scm index ccc1c27cb2..973bd5264e 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -54,6 +54,7 @@ #:use-module ((rnrs bytevectors) #:select (string->utf8)) #:export (inferior? open-inferior + port->inferior close-inferior inferior-eval inferior-eval-with-store @@ -93,10 +94,11 @@ ;; Inferior Guix process. (define-record-type <inferior> - (inferior pid socket version packages table) + (inferior pid socket close version packages table) inferior? (pid inferior-pid) (socket inferior-socket) + (close inferior-close-socket) ;procedure (version inferior-version) ;REPL protocol version (packages inferior-package-promise) ;promise of inferior packages (table inferior-package-table)) ;promise of vhash @@ -131,19 +133,17 @@ it's an old Guix." ((@ (guix scripts repl) machine-repl)))))) pipe))) -(define* (open-inferior directory #:key (command "bin/guix")) - "Open the inferior Guix in DIRECTORY, running 'DIRECTORY/COMMAND repl' or -equivalent. Return #f if the inferior could not be launched." - (define pipe - (inferior-pipe directory command)) - +(define* (port->inferior pipe #:optional (close close-port)) + "Given PIPE, an input/output port, return an inferior that talks over PIPE. +PIPE is closed with CLOSE when 'close-inferior' is called on the returned +inferior." (cond-expand ((and guile-2 (not guile-2.2)) #t) (else (setvbuf pipe 'line))) (match (read pipe) (('repl-version 0 rest ...) - (letrec ((result (inferior 'pipe pipe (cons 0 rest) + (letrec ((result (inferior 'pipe pipe close (cons 0 rest) (delay (%inferior-packages result)) (delay (%inferior-package-table result))))) (inferior-eval '(use-modules (guix)) result) @@ -155,9 +155,18 @@ equivalent. Return #f if the inferior could not be launched." (_ #f))) +(define* (open-inferior directory #:key (command "bin/guix")) + "Open the inferior Guix in DIRECTORY, running 'DIRECTORY/COMMAND repl' or +equivalent. Return #f if the inferior could not be launched." + (define pipe + (inferior-pipe directory command)) + + (port->inferior pipe close-pipe)) + (define (close-inferior inferior) "Close INFERIOR." - (close-pipe (inferior-socket inferior))) + (let ((close (inferior-close-socket inferior))) + (close (inferior-socket inferior)))) ;; Non-self-quoting object of the inferior. (define-record-type <inferior-object> @@ -409,6 +418,7 @@ thus be the code of a one-argument procedure that accepts a store." ;; Create a named socket in /tmp and let INFERIOR connect to it and use it ;; as its store. This ensures the inferior uses the same store, with the ;; same options, the same per-session GC roots, etc. + ;; FIXME: This strategy doesn't work for remote inferiors (SSH). (call-with-temporary-directory (lambda (directory) (chmod directory #o700) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 2314f3b28c..354f6f7031 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -8,6 +8,7 @@ ;;; Copyright © 2017 Alex Kost <alezost@gmail.com> ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr> ;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -44,8 +45,10 @@ #:use-module (guix cve) #:use-module (gnu packages) #:use-module (ice-9 match) + #:use-module (ice-9 receive) #:use-module (ice-9 regex) #:use-module (ice-9 format) + #:use-module (web client) #:use-module (web uri) #:use-module ((guix build download) #:select (maybe-expand-mirrors @@ -74,6 +77,7 @@ check-source check-source-file-name check-mirror-url + check-github-url check-license check-vulnerabilities check-for-updates @@ -773,6 +777,37 @@ descriptions maintained upstream." (let ((uris (origin-uris origin))) (for-each check-mirror-uri uris))))) +(define (check-github-url package) + "Check whether PACKAGE uses source URLs that redirect to GitHub." + (define (follow-redirect uri) + (receive (response body) (http-head uri) + (case (response-code response) + ((301 302) + (uri->string (assoc-ref (response-headers response) 'location))) + (else #f)))) + + (define (follow-redirects-to-github uri) + (cond + ((string-prefix? "https://github.com/" uri) uri) + ((string-prefix? "http" uri) + (and=> (follow-redirect uri) follow-redirects-to-github)) + ;; Do not attempt to follow redirects on URIs other than http and https + ;; (such as mirror, file) + (else #f))) + + (let ((origin (package-source package))) + (when (and (origin? origin) + (eqv? (origin-method origin) url-fetch)) + (for-each + (lambda (uri) + (and=> (follow-redirects-to-github uri) + (lambda (github-uri) + (emit-warning + package + (format #f (G_ "URL should be '~a'") github-uri) + 'source)))) + (origin-uris origin))))) + (define (check-derivation package) "Emit a warning if we fail to compile PACKAGE to a derivation." (define (try system) @@ -1056,6 +1091,10 @@ or a list thereof") (description "Suggest 'mirror://' URLs") (check check-mirror-url)) (lint-checker + (name 'github-uri) + (description "Suggest GitHub URIs") + (check check-github-url)) + (lint-checker (name 'source-file-name) (description "Validate file names of sources") (check check-source-file-name)) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index bfdaa3c011..dcdccc80e0 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -23,13 +23,12 @@ #:use-module (ssh session) #:use-module (ssh channel) #:use-module (ssh popen) - #:use-module (ssh dist) - #:use-module (ssh dist node) #:use-module (ssh version) #:use-module (guix config) #:use-module (guix records) #:use-module (guix ssh) #:use-module (guix store) + #:use-module (guix inferior) #:use-module (guix derivations) #:use-module ((guix serialization) #:select (nar-error? nar-error-file)) @@ -321,12 +320,15 @@ hook." (set-port-revealed! port 1) port)) +(define (node-guile-version node) + (inferior-eval '(version) node)) + (define (node-free-disk-space node) "Return the free disk space, in bytes, in NODE's store." - (node-eval node - `(begin - (use-modules (guix build syscalls)) - (free-disk-space ,(%store-prefix))))) + (inferior-eval `(begin + (use-modules (guix build syscalls)) + (free-disk-space ,(%store-prefix))) + node)) (define* (transfer-and-offload drv machine #:key @@ -367,8 +369,12 @@ MACHINE." (derivation-file-name drv) (build-machine-name machine) (nix-protocol-error-message c)) - (let* ((space (false-if-exception - (node-free-disk-space (make-node session))))) + (let* ((inferior (false-if-exception (remote-inferior session))) + (space (false-if-exception + (node-free-disk-space inferior)))) + + (when inferior + (close-inferior inferior)) ;; Use exit code 100 for a permanent build failure. The daemon ;; interprets other non-zero codes as transient build failures. @@ -417,11 +423,11 @@ of free disk space on '~a'~%") (define (node-load node) "Return the load on NODE. Return +∞ if NODE is misbehaving." - (let ((line (node-eval node - '(begin - (use-modules (ice-9 rdelim)) - (call-with-input-file "/proc/loadavg" - read-string))))) + (let ((line (inferior-eval '(begin + (use-modules (ice-9 rdelim)) + (call-with-input-file "/proc/loadavg" + read-string)) + node))) (if (eof-object? line) +inf.0 ;MACHINE does not respond, so assume it is infinitely loaded (match (string-tokenize line) @@ -508,9 +514,10 @@ slot (which must later be released with 'release-build-slot'), or #f and #f." ;; Note: We call 'node-load' only as a last resort because it is ;; too costly to call it once for every machine. (let* ((session (false-if-exception (open-ssh-session best))) - (node (and session (make-node session))) + (node (and session (remote-inferior session))) (load (and node (normalized-load best (node-load node)))) (space (and node (node-free-disk-space node)))) + (when node (close-inferior node)) (when session (disconnect! session)) (if (and node (< load 2.) (>= space %minimum-disk-space)) (match others @@ -613,40 +620,34 @@ If TIMEOUT is #f, simply evaluate EXP..." (#f (report-guile-error name)) ((? string? version) - ;; Note: The version string already contains the word "Guile". - (info (G_ "'~a' is running ~a~%") + (info (G_ "'~a' is running GNU Guile ~a~%") name (node-guile-version node))))) (define (assert-node-has-guix node name) - "Bail out if NODE lacks the (guix) module, or if its daemon is not running." - (catch 'node-repl-error - (lambda () - (match (node-eval node - '(begin + "Bail out if NODE if #f or if we fail to use the (guix) module, or if its +daemon is not running." + (unless (inferior? node) + (leave (G_ "failed to run 'guix repl' on '~a'~%") name)) + + (match (inferior-eval '(begin (use-modules (guix)) - (and add-text-to-store 'alright))) - ('alright #t) - (_ (report-module-error name)))) - (lambda (key . args) - (report-module-error name))) + (and add-text-to-store 'alright)) + node) + ('alright #t) + (_ (report-module-error name))) - (catch 'node-repl-error - (lambda () - (match (node-eval node - '(begin + (match (inferior-eval '(begin (use-modules (guix)) (with-store store (add-text-to-store store "test" - "Hello, build machine!")))) - ((? string? str) - (info (G_ "Guix is usable on '~a' (test returned ~s)~%") - name str)) - (x - (leave (G_ "failed to talk to guix-daemon on '~a' (test returned ~s)~%") - name x)))) - (lambda (key . args) - (leave (G_ "remote evaluation on '~a' failed:~{ ~s~}~%") - name args)))) + "Hello, build machine!"))) + node) + ((? string? str) + (info (G_ "Guix is usable on '~a' (test returned ~s)~%") + name str)) + (x + (leave (G_ "failed to talk to guix-daemon on '~a' (test returned ~s)~%") + name x)))) (define %random-state (delay @@ -656,25 +657,23 @@ If TIMEOUT is #f, simply evaluate EXP..." (string-append name "-" (number->string (random 1000000 (force %random-state))))) -(define (assert-node-can-import node name daemon-socket) +(define (assert-node-can-import session node name daemon-socket) "Bail out if NODE refuses to import our archives." - (let ((session (node-session node))) - (with-store store - (let* ((item (add-text-to-store store "export-test" (nonce))) - (remote (connect-to-remote-daemon session daemon-socket))) - (with-store local - (send-files local (list item) remote)) - - (if (valid-path? remote item) - (info (G_ "'~a' successfully imported '~a'~%") - name item) - (leave (G_ "'~a' was not properly imported on '~a'~%") - item name)))))) - -(define (assert-node-can-export node name daemon-socket) + (with-store store + (let* ((item (add-text-to-store store "export-test" (nonce))) + (remote (connect-to-remote-daemon session daemon-socket))) + (with-store local + (send-files local (list item) remote)) + + (if (valid-path? remote item) + (info (G_ "'~a' successfully imported '~a'~%") + name item) + (leave (G_ "'~a' was not properly imported on '~a'~%") + item name))))) + +(define (assert-node-can-export session node name daemon-socket) "Bail out if we cannot import signed archives from NODE." - (let* ((session (node-session node)) - (remote (connect-to-remote-daemon session daemon-socket)) + (let* ((remote (connect-to-remote-daemon session daemon-socket)) (item (add-text-to-store remote "import-test" (nonce name)))) (with-store store (if (and (retrieve-files store (list item) remote) @@ -701,11 +700,13 @@ machine." (let* ((names (map build-machine-name machines)) (sockets (map build-machine-daemon-socket machines)) (sessions (map open-ssh-session machines)) - (nodes (map make-node sessions))) - (for-each assert-node-repl nodes names) + (nodes (map remote-inferior sessions))) (for-each assert-node-has-guix nodes names) - (for-each assert-node-can-import nodes names sockets) - (for-each assert-node-can-export nodes names sockets)))) + (for-each assert-node-repl nodes names) + (for-each assert-node-can-import sessions nodes names sockets) + (for-each assert-node-can-export sessions nodes names sockets) + (for-each close-inferior nodes) + (for-each disconnect! sessions)))) (define (check-machine-status machine-file pred) "Print the load of each machine matching PRED in MACHINE-FILE." @@ -721,20 +722,28 @@ machine." (info (G_ "getting status of ~a build machines defined in '~a'...~%") (length machines) machine-file) (for-each (lambda (machine) - (let* ((session (open-ssh-session machine)) - (node (make-node session)) - (uts (node-eval node '(uname))) - (load (node-load node)) - (free (node-free-disk-space node))) - (disconnect! session) - (format #t "~a~% kernel: ~a ~a~% architecture: ~a~%\ + (define session + (open-ssh-session machine)) + + (match (remote-inferior session) + (#f + (warning (G_ "failed to run 'guix repl' on machine '~a'~%") + (build-machine-name machine))) + ((? inferior? inferior) + (let ((uts (inferior-eval '(uname) inferior)) + (load (node-load inferior)) + (free (node-free-disk-space inferior))) + (close-inferior inferior) + (format #t "~a~% kernel: ~a ~a~% architecture: ~a~%\ host name: ~a~% normalized load: ~a~% free disk space: ~,2f MiB~%" - (build-machine-name machine) - (utsname:sysname uts) (utsname:release uts) - (utsname:machine uts) - (utsname:nodename uts) - (normalized-load machine load) - (/ free (expt 2 20) 1.)))) + (build-machine-name machine) + (utsname:sysname uts) (utsname:release uts) + (utsname:machine uts) + (utsname:nodename uts) + (normalized-load machine load) + (/ free (expt 2 20) 1.))))) + + (disconnect! session)) machines))) diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 1d86f949c8..003c915da3 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -5,6 +5,7 @@ ;;; Copyright © 2015 Alex Kost <alezost@gmail.com> ;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> +;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il> ;;; ;;; This file is part of GNU Guix. ;;; @@ -40,6 +41,7 @@ #:use-module (ice-9 regex) #:use-module (ice-9 vlist) #:use-module (ice-9 format) + #:use-module (ice-9 threads) ; par-for-each #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -88,6 +90,12 @@ (option '(#\l "list-dependent") #f #f (lambda (opt name arg result) (alist-cons 'list-dependent? #t result))) + (option '(#\r "recursive") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive? #t result))) + (option '("list-transitive") #f #f + (lambda (opt name arg result) + (alist-cons 'list-transitive? #t result))) (option '("keyring") #t #f (lambda (opt name arg result) @@ -140,6 +148,10 @@ specified with `--select'.\n")) (display (G_ " -l, --list-dependent list top-level dependent packages that would need to be rebuilt as a result of upgrading PACKAGE...")) + (display (G_ " + -r, --recursive check the PACKAGE and its inputs for upgrades")) + (display (G_ " + --list-transitive list all the packages that PACKAGE depends on")) (newline) (display (G_ " --keyring=FILE use FILE as the keyring of upstream OpenPGP keys")) @@ -323,6 +335,43 @@ dependent packages are rebuilt: ~{~a~^ ~}~%" (map full-name covering)))) (return #t)))) +(define (refresh-recursive packages) + "Check all of the package inputs of PACKAGES for newer upstream versions." + (mlet %store-monad ((edges (node-edges %bag-node-type + ;; Here we don't want the -boot0 packages. + (fold-packages cons '())))) + (let ((dependent (node-transitive-edges packages edges))) + ;; par-for-each has an undefined return value, so packages which cause + ;; errors can be ignored. + (par-for-each (lambda (package) + (guix-refresh package)) + (map package-name dependent))) + (return #t))) + +(define (list-transitive packages) + "List all the packages that would cause PACKAGES to be rebuilt if they are changed." + ;; Using %BAG-NODE-TYPE is more accurate than using %PACKAGE-NODE-TYPE + ;; because it includes implicit dependencies. + (define (full-name package) + (string-append (package-name package) "@" + (package-version package))) + + (mlet %store-monad ((edges (node-edges %bag-node-type + ;; Here we don't want the -boot0 packages. + (fold-packages cons '())))) + (let ((dependent (node-transitive-edges packages edges))) + (match packages + ((x) + (format (current-output-port) + (G_ "~a depends on the following ~d packages: ~{~a~^ ~}~%.") + (full-name x) (length dependent) (map full-name dependent))) + (lst + (format (current-output-port) + (G_ "The following ~d packages \ +all are dependent packages: ~{~a~^ ~}~%") + (length dependent) (map full-name dependent)))) + (return #t)))) + ;;; ;;; Manifest. @@ -402,7 +451,9 @@ update would trigger a complete rebuild." (let* ((opts (parse-options)) (update? (assoc-ref opts 'update?)) (updaters (options->updaters opts)) + (recursive? (assoc-ref opts 'recursive?)) (list-dependent? (assoc-ref opts 'list-dependent?)) + (list-transitive? (assoc-ref opts 'list-transitive?)) (key-download (assoc-ref opts 'key-download)) ;; Warn about missing updaters when a package is explicitly given on @@ -441,6 +492,10 @@ update would trigger a complete rebuild." (cond (list-dependent? (list-dependents packages)) + (list-transitive? + (list-transitive packages)) + (recursive? + (refresh-recursive packages)) (update? (parameterize ((%openpgp-key-server (or (assoc-ref opts 'key-server) diff --git a/guix/ssh.scm b/guix/ssh.scm index 104f4f52d6..1ed8406633 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -18,6 +18,7 @@ (define-module (guix ssh) #:use-module (guix store) + #:use-module (guix inferior) #:use-module (guix i18n) #:use-module ((guix utils) #:select (&fix-hint)) #:use-module (ssh session) @@ -26,8 +27,6 @@ #:use-module (ssh channel) #:use-module (ssh popen) #:use-module (ssh session) - #:use-module (ssh dist) - #:use-module (ssh dist node) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -36,6 +35,7 @@ #:use-module (ice-9 match) #:use-module (ice-9 binary-ports) #:export (open-ssh-session + remote-inferior remote-daemon-channel connect-to-remote-daemon send-files @@ -94,6 +94,26 @@ Throw an error on failure." (message (format #f (G_ "SSH connection to '~a' failed: ~a~%") host (get-error session)))))))))) +(define (remote-inferior session) + "Return a remote inferior for the given SESSION." + (let ((pipe (open-remote-pipe* session OPEN_BOTH + "guix" "repl" "-t" "machine"))) + (port->inferior pipe))) + +(define (inferior-remote-eval exp session) + "Evaluate EXP in a new inferior running in SESSION, and close the inferior +right away." + (let ((inferior (remote-inferior session))) + (dynamic-wind + (const #t) + (lambda () + (inferior-eval exp inferior)) + (lambda () + ;; Close INFERIOR right away to prevent finalization from happening in + ;; another thread at the wrong time (see + ;; <https://bugs.gnu.org/26976>.) + (close-inferior inferior))))) + (define* (remote-daemon-channel session #:optional (socket-name @@ -269,15 +289,15 @@ Return the list of store items actually sent." ;; Compute the subset of FILES missing on SESSION and send them. (let* ((files (if recursive? (requisites local files) files)) (session (channel-get-session (nix-server-socket remote))) - (node (make-node session)) - (missing (node-eval node - `(begin - (use-modules (guix) - (srfi srfi-1) (srfi srfi-26)) - - (with-store store - (remove (cut valid-path? store <>) - ',files))))) + (missing (inferior-remote-eval + `(begin + (use-modules (guix) + (srfi srfi-1) (srfi srfi-26)) + + (with-store store + (remove (cut valid-path? store <>) + ',files))) + session)) (count (length missing)) (sizes (map (lambda (item) (path-info-nar-size (query-path-info local item))) diff --git a/tests/lint.scm b/tests/lint.scm index 300153e24e..d4aa7c0e8e 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -6,6 +6,7 @@ ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; Copyright © 2017 Alex Kost <alezost@gmail.com> ;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -669,6 +670,33 @@ (check-mirror-url (dummy-package "x" (source source))))) "mirror://gnu/foo/foo.tar.gz")) +(test-assert "github-url" + (string-null? + (with-warnings + (with-http-server 200 %long-string + (check-github-url + (dummy-package "x" (source + (origin + (method url-fetch) + (uri (%local-url)) + (sha256 %null-sha256))))))))) + +(let ((github-url "https://github.com/foo/bar/bar-1.0.tar.gz")) + (test-assert "github-url: one suggestion" + (string-contains + (with-warnings + (with-http-server (301 `((location . ,(string->uri github-url)))) "" + (let ((initial-uri (%local-url))) + (parameterize ((%http-server-port (+ 1 (%http-server-port)))) + (with-http-server (302 `((location . ,(string->uri initial-uri)))) "" + (check-github-url + (dummy-package "x" (source + (origin + (method url-fetch) + (uri (%local-url)) + (sha256 %null-sha256)))))))))) + github-url))) + (test-assert "cve" (mock ((guix scripts lint) package-vulnerabilities (const '())) (string-null? |