Merge branch 'master' into staging

master
Marius Bakke 2018-12-26 16:03:09 +01:00
commit 2bfcdbce51
No known key found for this signature in database
GPG Key ID: A2A06DF2A33A54FA
28 changed files with 756 additions and 205 deletions

View File

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

View File

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

View File

@ -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)
("aubio" ,aubio)
("lrdf" ,lrdf)
("boost" ,boost)
("atkmm" ,atkmm)
("aubio" ,aubio)
("boost" ,boost)
("cairomm" ,cairomm)
("eudev" ,eudev)
("gtkmm" ,gtkmm-2)
("glibmm" ,glibmm)
("libart-lgpl" ,libart-lgpl)
("libgnomecanvasmm" ,libgnomecanvasmm)
("pangomm" ,pangomm)
("liblo" ,liblo)
("libsndfile" ,libsndfile)
("libsamplerate" ,libsamplerate)
("libxml2" ,libxml2)
("libogg" ,libogg)
("libvorbis" ,libvorbis)
("flac" ,flac)
("lv2" ,lv2)
("vamp" ,vamp)
("curl" ,curl)
("eudev" ,eudev)
("fftw" ,fftw)
("fftwf" ,fftwf)
("flac" ,flac)
("glibmm" ,glibmm)
("gtkmm" ,gtkmm-2)
("jack" ,jack-1)
("libarchive" ,libarchive)
("libart-lgpl" ,libart-lgpl)
("libgnomecanvasmm" ,libgnomecanvasmm)
("liblo" ,liblo)
("libogg" ,libogg)
("libsamplerate" ,libsamplerate)
("libsndfile" ,libsndfile)
("libusb" ,libusb)
("libvorbis" ,libvorbis)
("libxml2" ,libxml2)
("lilv" ,lilv)
("lrdf" ,lrdf)
("lv2" ,lv2)
("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")

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -509,27 +509,28 @@ is Pythons.")
(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")

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -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)
@ -1055,6 +1090,10 @@ or a list thereof")
(name 'mirror-url)
(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")

View File

@ -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
(use-modules (guix))
(and add-text-to-store 'alright)))
('alright #t)
(_ (report-module-error name))))
(lambda (key . args)
(report-module-error name)))
"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))
(catch 'node-repl-error
(lambda ()
(match (node-eval node
'(begin
(match (inferior-eval '(begin
(use-modules (guix))
(and add-text-to-store 'alright))
node)
('alright #t)
(_ (report-module-error name)))
(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))
(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))))))
(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)
(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)))

View File

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

View File

@ -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))
(missing (inferior-remote-eval
`(begin
(use-modules (guix)
(srfi srfi-1) (srfi srfi-26))
(with-store store
(remove (cut valid-path? store <>)
',files)))))
(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)))

View File

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