From 043a51c0c2a025b84b0fb14c157add7236d7a526 Mon Sep 17 00:00:00 2001 From: Hartmut Goebel Date: Sun, 2 Oct 2016 18:48:56 +0200 Subject: guix: python-build-system: Fix an outdated comment. --- guix/build/python-build-system.scm | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/build/python-build-system.scm b/guix/build/python-build-system.scm index 9109fb4ac7..e906e60699 100644 --- a/guix/build/python-build-system.scm +++ b/guix/build/python-build-system.scm @@ -137,8 +137,7 @@ (define* (ensure-no-mtimes-pre-1980 #:rest _) #t)) (define %standard-phases - ;; 'configure' and 'build' phases are not needed. Everything is done during - ;; 'install'. + ;; 'configure' phase is not needed. (modify-phases gnu:%standard-phases (add-after 'unpack 'ensure-no-mtimes-pre-1980 ensure-no-mtimes-pre-1980) (delete 'configure) -- cgit v1.2.3 From 7db40bce58e149ecb541d295e01cfbfe953d39a3 Mon Sep 17 00:00:00 2001 From: Hartmut Goebel Date: Wed, 28 Sep 2016 10:42:35 +0200 Subject: guix: build all Python packages with --single-version-externally-managed. This requires setuptools to be installed together with python, which is the case for Python 3 anyway and which we do for our build of Python 2 (see last commit). * guix/build/python-build-system.scm (install): Add "--single-version-externally-managed" and "--root=/" to params to be passed to call-setuppy. Remove thus needless manipulation of PYTHONPATH. Remove now unused argument "inputs". --- guix/build/python-build-system.scm | 23 +++++++---------------- 1 file changed, 7 insertions(+), 16 deletions(-) (limited to 'guix') diff --git a/guix/build/python-build-system.scm b/guix/build/python-build-system.scm index e906e60699..2424fed310 100644 --- a/guix/build/python-build-system.scm +++ b/guix/build/python-build-system.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2013 Andreas Enge ;;; Copyright © 2013 Nikita Karetnikov ;;; Copyright © 2015 Mark H Weaver +;;; Copyright © 2016 Hartmut Goebel ;;; ;;; This file is part of GNU Guix. ;;; @@ -60,25 +61,15 @@ (define (get-python-version python) (major+minor (take components 2))) (string-join major+minor "."))) -(define* (install #:key outputs inputs (configure-flags '()) +(define* (install #:key outputs (configure-flags '()) #:allow-other-keys) "Install a given Python package." (let* ((out (assoc-ref outputs "out")) - (params (append (list (string-append "--prefix=" out)) - configure-flags)) - (python-version (get-python-version (assoc-ref inputs "python"))) - (old-path (getenv "PYTHONPATH")) - (add-path (string-append out "/lib/python" python-version - "/site-packages/"))) - ;; create the module installation directory and add it to PYTHONPATH - ;; to make setuptools happy - (mkdir-p add-path) - (setenv "PYTHONPATH" - (string-append (if old-path - (string-append old-path ":") - "") - add-path)) - (call-setuppy "install" params))) + (params (append (list (string-append "--prefix=" out) + "--single-version-externally-managed" + "--root=/") + configure-flags))) + (call-setuppy "install" params))) (define* (wrap #:key inputs outputs #:allow-other-keys) (define (list-of-files dir) -- cgit v1.2.3 From 46bcdcc287ecfc1db8b7a0429e72517f407b580d Mon Sep 17 00:00:00 2001 From: Marius Bakke Date: Thu, 29 Sep 2016 18:41:35 +0100 Subject: guix: python-build-system: Import setuptools before calling `setup.py'. This is needed for packages using "distutils" instead of "setuptools" since the former does not understand the "--single-version-externally-managed" flag. Also export __file__ since it will be unset when setup.py is called from python "exec". * guix/build/python-build-system.scm (call-setuppy): extend "python setup.py" call to import setuptools, export __file__, and call setup.py from setuptools python environment. Co-Authored-By: Hartmut Goebel --- guix/build/python-build-system.scm | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/python-build-system.scm b/guix/build/python-build-system.scm index 2424fed310..6086df3e82 100644 --- a/guix/build/python-build-system.scm +++ b/guix/build/python-build-system.scm @@ -36,13 +36,25 @@ (define-module (guix build python-build-system) ;; ;; Code: +(define setuptools-shim + ;; Run setup.py with "setuptools" being imported, which will patch + ;; "distutils". This is needed for packages using "distutils" instead of + ;; "setuptools" since the former does not understand the + ;; "--single-version-externally-managed" flag. + ;; Python code taken from pip 9.0.1 pip/utils/setuptools_build.py + (string-append + "import setuptools, tokenize;__file__='setup.py';" + "f=getattr(tokenize, 'open', open)(__file__);" + "code=f.read().replace('\\r\\n', '\\n');" + "f.close();" + "exec(compile(code, __file__, 'exec'))")) (define (call-setuppy command params) (if (file-exists? "setup.py") (begin (format #t "running \"python setup.py\" with command ~s and parameters ~s~%" command params) - (zero? (apply system* "python" "setup.py" command params))) + (zero? (apply system* "python" "-c" setuptools-shim command params))) (error "no setup.py found"))) (define* (build #:rest empty) -- cgit v1.2.3 From 5f7565d190cf380b7bae2ce12dba38aff98c4eb9 Mon Sep 17 00:00:00 2001 From: Hartmut Goebel Date: Sun, 2 Oct 2016 14:03:32 +0200 Subject: guix: python-build-system: Add option "#:use-setuptools?" (default true). * guix/build-system/python.scm (python-build): New keyword argument "#:use-setuptools?", defaulting to #t. * guix/build/python-build-system.scm (call-setup-py): New positional parameter "use-setuptools?". If false, do not use the shim-wrapper for addin setuptools. (build, check): accept keyword- parameter, and pass to call-setuppy. (install): same; if "use-setuptools?" is false, do not use options "--root" and "--single-version-externally-managed" for setup.py. * doc/guix.texi (Build Systems): Document it. --- doc/guix.texi | 5 +++++ guix/build-system/python.scm | 2 ++ guix/build/python-build-system.scm | 28 +++++++++++++++++----------- 3 files changed, 24 insertions(+), 11 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 2691e24faf..5f2807654b 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3137,6 +3137,11 @@ the @code{#:python} parameter. This is a useful way to force a package to be built for a specific version of the Python interpreter, which might be necessary if the package is only compatible with a single interpreter version. + +By default guix calls @code{setup.py} under control of +@code{setuptools}, much like @command{pip} does. Some packages are not +compatible with setuptools (and pip), thus you can disable this by +setting the @code{#:use-setuptools} parameter to @code{#f}. @end defvr @defvr {Scheme Variable} perl-build-system diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm index adeceb4a89..d4d3d28f2a 100644 --- a/guix/build-system/python.scm +++ b/guix/build-system/python.scm @@ -177,6 +177,7 @@ (define* (python-build store name inputs #:key (tests? #t) (test-target "test") + (use-setuptools? #t) (configure-flags ''()) (phases '(@ (guix build python-build-system) %standard-phases)) @@ -204,6 +205,7 @@ (define builder #:system ,system #:test-target ,test-target #:tests? ,tests? + #:use-setuptools? ,use-setuptools? #:phases ,phases #:outputs %outputs #:search-paths ',(map search-path-specification->sexp diff --git a/guix/build/python-build-system.scm b/guix/build/python-build-system.scm index 6086df3e82..7ccc9386cf 100644 --- a/guix/build/python-build-system.scm +++ b/guix/build/python-build-system.scm @@ -49,22 +49,25 @@ (define setuptools-shim "f.close();" "exec(compile(code, __file__, 'exec'))")) -(define (call-setuppy command params) +(define (call-setuppy command params use-setuptools?) (if (file-exists? "setup.py") (begin (format #t "running \"python setup.py\" with command ~s and parameters ~s~%" command params) - (zero? (apply system* "python" "-c" setuptools-shim command params))) + (if use-setuptools? + (zero? (apply system* "python" "-c" setuptools-shim + command params)) + (zero? (apply system* "python" "./setup.py" command params)))) (error "no setup.py found"))) -(define* (build #:rest empty) +(define* (build #:key use-setuptools? #:allow-other-keys) "Build a given Python package." - (call-setuppy "build" '())) + (call-setuppy "build" '() use-setuptools?)) -(define* (check #:key tests? test-target #:allow-other-keys) +(define* (check #:key tests? test-target use-setuptools? #:allow-other-keys) "Run the test suite of a given Python package." (if tests? - (call-setuppy test-target '()) + (call-setuppy test-target '() use-setuptools?) #t)) (define (get-python-version python) @@ -73,15 +76,18 @@ (define (get-python-version python) (major+minor (take components 2))) (string-join major+minor "."))) -(define* (install #:key outputs (configure-flags '()) +(define* (install #:key outputs (configure-flags '()) use-setuptools? #:allow-other-keys) "Install a given Python package." (let* ((out (assoc-ref outputs "out")) - (params (append (list (string-append "--prefix=" out) - "--single-version-externally-managed" - "--root=/") + (params (append (list (string-append "--prefix=" out)) + (if use-setuptools? + ;; distutils does not accept these flags + (list "--single-version-externally-managed" + "--root=/") + '()) configure-flags))) - (call-setuppy "install" params))) + (call-setuppy "install" params use-setuptools?))) (define* (wrap #:key inputs outputs #:allow-other-keys) (define (list-of-files dir) -- cgit v1.2.3 From a2ff4f0240f0fac484836bb8ffb2f86917369666 Mon Sep 17 00:00:00 2001 From: Hartmut Goebel Date: Sat, 8 Oct 2016 12:04:20 +0200 Subject: guix: python-build-system: Add helpers for getting and setting PYTHONPATH. * guix/build/python-build-system.scm (add-installed-pythonpath, site-packages): New exported procedures. --- guix/build/python-build-system.scm | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) (limited to 'guix') diff --git a/guix/build/python-build-system.scm b/guix/build/python-build-system.scm index 7ccc9386cf..22c4f7d38a 100644 --- a/guix/build/python-build-system.scm +++ b/guix/build/python-build-system.scm @@ -28,6 +28,8 @@ (define-module (guix build python-build-system) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (%standard-phases + add-installed-pythonpath + site-packages python-build)) ;; Commentary: @@ -76,6 +78,24 @@ (define (get-python-version python) (major+minor (take components 2))) (string-join major+minor "."))) +(define (site-packages inputs outputs) + "Return the path of the current output's Python site-package." + (let* ((out (assoc-ref outputs "out")) + (python (assoc-ref inputs "python"))) + (string-append out "/lib/python" + (get-python-version python) + "/site-packages/"))) + +(define (add-installed-pythonpath inputs outputs) + "Prepend the Python site-package of OUTPUT to PYTHONPATH. This is useful +when running checks after installing the package." + (let ((old-path (getenv "PYTHONPATH")) + (add-path (site-packages inputs outputs))) + (setenv "PYTHONPATH" + (string-append add-path + (if old-path (string-append ":" old-path) ""))) + #t)) + (define* (install #:key outputs (configure-flags '()) use-setuptools? #:allow-other-keys) "Install a given Python package." -- cgit v1.2.3 From b002f964bb3d69c77856ea7dcadfe82383050512 Mon Sep 17 00:00:00 2001 From: Hartmut Goebel Date: Fri, 7 Oct 2016 17:17:00 +0200 Subject: guix: python-build-system: Delete .egg-info file created in phase check. * guix/build/python-build-system.scm (check): Delete .egg-info dirs which did not exist prior to calling setup.py but afterwards. --- guix/build/python-build-system.scm | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/python-build-system.scm b/guix/build/python-build-system.scm index 22c4f7d38a..310ba8aa2e 100644 --- a/guix/build/python-build-system.scm +++ b/guix/build/python-build-system.scm @@ -69,7 +69,15 @@ (define* (build #:key use-setuptools? #:allow-other-keys) (define* (check #:key tests? test-target use-setuptools? #:allow-other-keys) "Run the test suite of a given Python package." (if tests? - (call-setuppy test-target '() use-setuptools?) + ;; Running `setup.py test` creates an additional .egg-info directory in + ;; build/lib in some cases, e.g. if the source is in a sub-directory + ;; (given with `package_dir`). This will by copied to the output, too, + ;; so we need to remove. + (let ((before (find-files "build" "\\.egg-info$" #:directories? #t))) + (call-setuppy test-target '() use-setuptools?) + (let* ((after (find-files "build" "\\.egg-info$" #:directories? #t)) + (inter (lset-difference eqv? after before))) + (for-each delete-file-recursively inter))) #t)) (define (get-python-version python) -- cgit v1.2.3 From c1019287a4aab55ebffab4710b9a85b6c9f1b7ed Mon Sep 17 00:00:00 2001 From: Hartmut Goebel Date: Tue, 15 Nov 2016 16:57:21 +0100 Subject: guix: python-build-system: Add background about Python installation methods. --- guix/build/python-build-system.scm | 68 +++++++++++++++++++++++++++++++++++++- 1 file changed, 67 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/python-build-system.scm b/guix/build/python-build-system.scm index 310ba8aa2e..3f280b0ac0 100644 --- a/guix/build/python-build-system.scm +++ b/guix/build/python-build-system.scm @@ -36,7 +36,70 @@ (define-module (guix build python-build-system) ;; ;; Builder-side code of the standard Python package build procedure. ;; -;; Code: +;; +;; Backgound about the Python installation methods +;; +;; In Python there are different ways to install packages: distutils, +;; setuptools, easy_install and pip. All of these are sharing the file +;; setup.py, introduced with distutils in Python 2.0. The setup.py file can be +;; considered as a kind of Makefile accepting targets (or commands) like +;; "build" and "install". As of autumn 2016 the recommended way to install +;; Python packages is using pip. +;; +;; For both distutils and setuptools, running "python setup.py install" is the +;; way to install Python packages. With distutils the "install" command +;; basically copies all packages into /lib/pythonX.Y/site-packages. +;; +;; Some time later "setuptools" was established to enhance distutils. To use +;; setuptools, the developer imports setuptools in setup.py. When importing +;; setuptools, the original "install" command gets overwritten by setuptools' +;; "install" command. +;; +;; The command-line tools easy_install and pip are both capable of finding and +;; downloading the package source from PyPI (the Python Package Index). Both +;; of them import setuptools and execute the "setup.py" file under their +;; control. Thus the "setup.py" behaves as if the developer had imported +;; setuptools within setup.py - even is still using only distutils. +;; +;; Setuptools' "install" command (to be more precise: the "easy_install" +;; command which is called by "install") will put the path of the currently +;; installed version of each package and it's dependencies (as declared in +;; setup.py) into an "easy-install.pth" file. In Guix each packages gets its +;; own "site-packages" directory and thus an "easy-install.pth" of its own. +;; To avoid conflicts, the python build system renames the file to +;; .pth in the phase rename-pth-file. To ensure that Python will +;; process the .pth file, easy_install also creates a basic "site.py" in each +;; "site-packages" directory. The file is the same for all packages, thus +;; there is no need to rename it. For more information about .pth files and +;; the site module, please refere to +;; https://docs.python.org/3/library/site.html. +;; +;; The .pth files contain the file-system paths (pointing to the store) of all +;; dependencies. So the dependency is hidden in the .pth file but is not +;; visible in the file-system. Now if packages A and B both required packages +;; P, but in different versions, Guix will not detect this when installing +;; both A and B to a profile. (For details and example see +;; https://lists.gnu.org/archive/html/guix-devel/2016-10/msg01233.html.) +;; +;; Pip behaves a bit different then easy_install: it always executes +;; "setup.py" with the option "--single-version-externally-managed" set. This +;; makes setuptools' "install" command run the original "install" command +;; instead of the "easy_install" command, so no .pth file (and no site.py) +;; will be created. The "site-packages" directory only contains the package +;; and the related .egg-info directory. +;; +;; This is exactly what we need for Guix and this is what we mimic in the +;; install phase below. +;; +;; As a draw back, the magic of the .pth file of linking to the other required +;; packages is gone and these packages have now to be declared as +;; "propagated-inputs". +;; +;; Note: Importing setuptools also adds two sub-commands: "install_egg_info" +;; and "install_scripts". These sub-commands are executed even if +;; "--single-version-externally-managed" is set, thus the .egg-info directory +;; and the scripts defined in entry-points will always be created. + (define setuptools-shim ;; Run setup.py with "setuptools" being imported, which will patch @@ -149,6 +212,9 @@ (define bindirs (define* (rename-pth-file #:key name inputs outputs #:allow-other-keys) "Rename easy-install.pth to NAME.pth to avoid conflicts between packages installed with setuptools." + ;; Even if the "easy-install.pth" is not longer created, we kept this phase. + ;; There still may be packages creating an "easy-install.pth" manually for + ;; some good reason. (let* ((out (assoc-ref outputs "out")) (python (assoc-ref inputs "python")) (site-packages (string-append out "/lib/python" -- cgit v1.2.3 From 891a843d5184f696618af6fcbb9791ef6b574504 Mon Sep 17 00:00:00 2001 From: Hartmut Goebel Date: Wed, 28 Sep 2016 11:36:35 +0200 Subject: guix: Add lint-checker for packages which should be no inputs at all. Also refactor some common code into a new function. Examples for these pacakges are python(2)-setuptools and python(2)-pip, which are installed together with python itself. * guix/scripts/lint.scm (warn-if-package-has-input): New procedure. (check-inputs-should-be-native package): Use it; rename and clean-up variables. (check-inputs-should-not-be-an-input-at-all): New procedure. (%checkers) Add it. * doc/guix.texi (Python Modules): Document it. * tests/lint.scm: ("inputs: python-setuptools should not be an input at all (input)", "inputs: python-setuptools should not be an input at all (native-input)" "inputs: python-setuptools should not be an input at all (propagated-input)"): Add tests. --- doc/guix.texi | 3 ++- guix/scripts/lint.scm | 63 ++++++++++++++++++++++++++++++++++++--------------- tests/lint.scm | 34 +++++++++++++++++++++++++++ 3 files changed, 81 insertions(+), 19 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 5f2807654b..40a1a8760c 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -13602,7 +13602,8 @@ following check list to determine which dependency goes where. @item We currently package Python 2 with @code{setuptools} and @code{pip} installed like Python 3.4 has per default. Thus you don't need to -specify either of these as an input. +specify either of these as an input. @command{guix lint} will warn you +if you do. @item Python dependencies required at run time go into diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 6e6f550941..e68ee29e07 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès ;;; Copyright © 2015, 2016 Mathieu Lirzin ;;; Copyright © 2016 Danny Milosavljevic +;;; Copyright © 2016 Hartmut Goebel ;;; ;;; This file is part of GNU Guix. ;;; @@ -59,6 +60,7 @@ (define-module (guix scripts lint) #:export (guix-lint check-description-style check-inputs-should-be-native + check-inputs-should-not-be-an-input-at-all check-patch-file-names check-synopsis-style check-derivation @@ -228,34 +230,55 @@ (define (check-end-of-sentence-space description) (format #f (_ "invalid description: ~s") description) 'description)))) +(define (warn-if-package-has-input linted inputs-to-check input-names message) + ;; Emit a warning MESSAGE if some of the inputs named in INPUT-NAMES are + ;; contained in INPUTS-TO-CHECK, which are assumed to be inputs of package + ;; LINTED. + (match inputs-to-check + (((labels packages . outputs) ...) + (for-each (lambda (package output) + (when (package? package) + (let ((input (string-append + (package-name package) + (if (> (length output) 0) + (string-append ":" (car output)) + "")))) + (when (member input input-names) + (emit-warning linted + (format #f (_ message) input) + 'inputs-to-check))))) + packages outputs)))) + (define (check-inputs-should-be-native package) ;; Emit a warning if some inputs of PACKAGE are likely to belong to its ;; native inputs. - (let ((linted package) + (let ((message "'~a' should probably be a native input") (inputs (package-inputs package)) - (native-inputs + (input-names '("pkg-config" "extra-cmake-modules" "glib:bin" "intltool" "itstool" "qttools"))) - (match inputs - (((labels packages . outputs) ...) - (for-each (lambda (package output) - (when (package? package) - (let ((input (string-append - (package-name package) - (if (> (length output) 0) - (string-append ":" (car output)) - "")))) - (when (member input native-inputs) - (emit-warning linted - (format #f (_ "'~a' should probably \ -be a native input") - input) - 'inputs))))) - packages outputs))))) + (warn-if-package-has-input package inputs input-names message))) + +(define (check-inputs-should-not-be-an-input-at-all package) + ;; Emit a warning if some inputs of PACKAGE are likely to should not be + ;; an input at all. + (let ((message "'~a' should probably not be an input at all") + (inputs (package-inputs package)) + (input-names + '("python-setuptools" + "python2-setuptools" + "python-pip" + "python2-pip"))) + (warn-if-package-has-input package (package-inputs package) + input-names message) + (warn-if-package-has-input package (package-native-inputs package) + input-names message) + (warn-if-package-has-input package (package-propagated-inputs package) + input-names message))) (define (package-name-regexp package) "Return a regexp that matches PACKAGE's name as a word at the beginning of a @@ -844,6 +867,10 @@ (define %checkers (name 'inputs-should-be-native) (description "Identify inputs that should be native inputs") (check check-inputs-should-be-native)) + (lint-checker + (name 'inputs-should-not-be-input) + (description "Identify inputs that should be inputs at all") + (check check-inputs-should-not-be-an-input-at-all)) (lint-checker (name 'patch-file-names) (description "Validate file names and availability of patches") diff --git a/tests/lint.scm b/tests/lint.scm index fa2d19b2a6..b66cd29312 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2014, 2015, 2016 Eric Bavier ;;; Copyright © 2014, 2015, 2016 Ludovic Courtès ;;; Copyright © 2015, 2016 Mathieu Lirzin +;;; Copyright © 2016 Hartmut Goebel ;;; ;;; This file is part of GNU Guix. ;;; @@ -33,6 +34,7 @@ (define-module (test-lint) #:use-module (gnu packages) #:use-module (gnu packages glib) #:use-module (gnu packages pkg-config) + #:use-module (gnu packages python) #:use-module (web server) #:use-module (web server http) #:use-module (web response) @@ -354,6 +356,38 @@ (define-syntax-rule (with-warnings body ...) (check-inputs-should-be-native pkg))) "'glib:bin' should probably be a native input"))) +(test-assert + "inputs: python-setuptools should not be an input at all (input)" + (->bool + (string-contains + (with-warnings + (let ((pkg (dummy-package "x" + (inputs `(("python-setuptools" ,python-setuptools)))))) + (check-inputs-should-not-be-an-input-at-all pkg))) + "'python-setuptools' should probably not be an input at all"))) + +(test-assert + "inputs: python-setuptools should not be an input at all (native-input)" + (->bool + (string-contains + (with-warnings + (let ((pkg (dummy-package "x" + (native-inputs + `(("python-setuptools" ,python-setuptools)))))) + (check-inputs-should-not-be-an-input-at-all pkg))) + "'python-setuptools' should probably not be an input at all"))) + +(test-assert + "inputs: python-setuptools should not be an input at all (propagated-input)" + (->bool + (string-contains + (with-warnings + (let ((pkg (dummy-package "x" + (propagated-inputs + `(("python-setuptools" ,python-setuptools)))))) + (check-inputs-should-not-be-an-input-at-all pkg))) + "'python-setuptools' should probably not be an input at all"))) + (test-assert "patches: file names" (->bool (string-contains -- cgit v1.2.3 From e442246a2f5f73b2484adb340b53d3a0018636b1 Mon Sep 17 00:00:00 2001 From: Hartmut Goebel Date: Thu, 6 Oct 2016 16:52:31 +0200 Subject: lint: more packages to probably be a native input. * guix/scripts/lint.scm (check-inputs-should-be-native package): Add python packages which are typically used for testing or for building the documentation. --- guix/scripts/lint.scm | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index e68ee29e07..be29e36ce1 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -260,7 +260,17 @@ (define (check-inputs-should-be-native package) "glib:bin" "intltool" "itstool" - "qttools"))) + "qttools" + "python-coverage" "python2-coverage" + "python-cython" "python2-cython" + "python-docutils" "python2-docutils" + "python-mock" "python2-mock" + "python-nose" "python2-nose" + "python-pbr" "python2-pbr" + "python-pytest" "python2-pytest" + "python-pytest-cov" "python2-pytest-cov" + "python-setuptools-scm" "python2-setuptools-scm" + "python-sphinx" "python2-sphinx"))) (warn-if-package-has-input package inputs input-names message))) (define (check-inputs-should-not-be-an-input-at-all package) -- cgit v1.2.3 From 21531add3205e400707c8fbfd841845f9a71863a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 2 Mar 2014 22:39:48 +0100 Subject: offload: Use Guile-SSH instead of GNU lsh. * guix/scripts/offload.scm ()[ssh-options]: Remove. [host-key, host-key-type]: New fields. (%lsh-command, %lshg-command, user-lsh-private-key): Remove. (user-openssh-private-key, private-key-from-file*): New procedures. (host-key->type+key, open-ssh-session): New procedures. (remote-pipe): Remove 'mode' parameter. Rewrite in terms of 'open-ssh-session' etc. Update users. (send-files)[missing-files]: Rewrite using the bidirectional channel port. Remove call to 'call-with-compressed-output-port'. (retrieve-files): Remove call to 'call-with-decompressed-port'. (machine-load): Remove exit status logic. * doc/guix.texi (Requirements): Mention Guile-SSH. (Daemon Offload Setup): Document 'host-key' and 'private-key'. Show the default value on each @item line. * m4/guix.m4 (GUIX_CHECK_GUILE_SSH): New macro. * config-daemon.ac: Use 'GUIX_CHECK_GUILE_SSH'. Set 'HAVE_DAEMON_OFFLOAD_HOOK' as a function of that. --- config-daemon.ac | 18 ++- doc/guix.texi | 69 ++++++++---- guix/scripts/offload.scm | 279 ++++++++++++++++++++++------------------------- m4/guix.m4 | 18 +++ 4 files changed, 213 insertions(+), 171 deletions(-) (limited to 'guix') diff --git a/config-daemon.ac b/config-daemon.ac index 8a3e6d8b60..056c939e39 100644 --- a/config-daemon.ac +++ b/config-daemon.ac @@ -128,12 +128,20 @@ if test "x$guix_build_daemon" = "xyes"; then dnl 'restore-file-set', which requires unbuffered custom binary input dnl ports from Guile >= 2.0.10.) GUIX_CHECK_UNBUFFERED_CBIP - guix_build_daemon_offload="$ac_cv_guix_cbips_support_setvbuf" - if test "x$guix_build_daemon_offload" = "xyes"; then - AC_DEFINE([HAVE_DAEMON_OFFLOAD_HOOK], [1], - [Define if the daemon's 'offload' build hook is being built.]) - fi + dnl Check for Guile-SSH, which is required by 'guix offload'. + GUIX_CHECK_GUILE_SSH + + case "x$ac_cv_guix_cbips_support_setvbuf$guix_cv_have_recent_guile_ssh" in + xyesyes) + guix_build_daemon_offload="yes" + AC_DEFINE([HAVE_DAEMON_OFFLOAD_HOOK], [1], + [Define if the daemon's 'offload' build hook is being built (requires Guile-SSH).]) + ;; + *) + guix_build_daemon_offload="no" + ;; + esac dnl Temporary directory used to store the daemon's data. GUIX_TEST_ROOT_DIRECTORY diff --git a/doc/guix.texi b/doc/guix.texi index ebb138e15d..f1cb007aa9 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -566,6 +566,12 @@ allow you to use the @command{guix import pypi} command (@pxref{Invoking guix import}). It is of interest primarily for developers and not for casual users. +@item +@c Note: We need at least 0.10.2 for 'channel-send-eof'. +Support for build offloading (@pxref{Daemon Offload Setup}) depends on +@uref{https://github.com/artyom-poptsov/guile-ssh, Guile-SSH}, +version 0.10.2 or later. + @item When @url{http://zlib.net, zlib} is available, @command{guix publish} can compress build byproducts (@pxref{Invoking guix publish}). @@ -814,9 +820,11 @@ available on the system---making it much harder to view them as @cindex offloading @cindex build hook -When desired, the build daemon can @dfn{offload} -derivation builds to other machines -running Guix, using the @code{offload} @dfn{build hook}. When that +When desired, the build daemon can @dfn{offload} derivation builds to +other machines running Guix, using the @code{offload} @dfn{build +hook}@footnote{This feature is available only when +@uref{https://github.com/artyom-poptsov/guile-ssh, Guile-SSH} is +present.}. When that feature is enabled, a list of user-specified build machines is read from @file{/etc/guix/machines.scm}; every time a build is requested, for instance via @code{guix build}, the daemon attempts to offload it to one @@ -832,16 +840,18 @@ The @file{/etc/guix/machines.scm} file typically looks like this: (list (build-machine (name "eightysix.example.org") (system "x86_64-linux") + (host-key "ssh-ed25519 AAAAC3Nza@dots{}") (user "bob") - (speed 2.)) ; incredibly fast! + (speed 2.)) ;incredibly fast! (build-machine (name "meeps.example.org") (system "mips64el-linux") + (host-key "ssh-rsa AAAAB3Nza@dots{}") (user "alice") (private-key (string-append (getenv "HOME") - "/.lsh/identity-for-guix")))) + "/.ssh/identity-for-guix")))) @end example @noindent @@ -875,31 +885,50 @@ The user account to use when connecting to the remote machine over SSH. Note that the SSH key pair must @emph{not} be passphrase-protected, to allow non-interactive logins. +@item host-key +This must be the machine's SSH @dfn{public host key} in OpenSSH format. +This is used to authenticate the machine when we connect to it. It is a +long string that looks like this: + +@example +ssh-ed25519 AAAAC3NzaC@dots{}mde+UhL hint@@example.org +@end example + +If the machine is running the OpenSSH daemon, @command{sshd}, the host +key can be found in a file such as +@file{/etc/ssh/ssh_host_ed25519_key.pub}. + +If the machine is running the SSH daemon of GNU@tie{}lsh, +@command{lshd}, the host key is in @file{/etc/lsh/host-key.pub} or a +similar file. It can be converted to the OpenSSH format using +@command{lsh-export-key} (@pxref{Converting keys,,, lsh, LSH Manual}): + +@example +$ lsh-export-key --openssh < /etc/lsh/host-key.pub +ssh-rsa AAAAB3NzaC1yc2EAAAAEOp8FoQAAAQEAs1eB46LV@dots{} +@end example + @end table A number of optional fields may be specified: -@table @code - -@item port -Port number of SSH server on the machine (default: 22). +@table @asis -@item private-key -The SSH private key file to use when connecting to the machine. +@item @code{port} (default: @code{22}) +Port number of SSH server on the machine. -Currently offloading uses GNU@tie{}lsh as its SSH client -(@pxref{Invoking lsh,,, GNU lsh Manual}). Thus, the key file here must -be an lsh key file. This may change in the future, though. +@item @code{private-key} (default: @file{~/.ssh/id_rsa}) +The SSH private key file to use when connecting to the machine, in +OpenSSH format. -@item parallel-builds -The number of builds that may run in parallel on the machine (1 by -default.) +@item @code{parallel-builds} (default: @code{1}) +The number of builds that may run in parallel on the machine. -@item speed +@item @code{speed} (default: @code{1.0}) A ``relative speed factor''. The offload scheduler will tend to prefer machines with a higher speed factor. -@item features +@item @code{features} (default: @code{'()}) A list of strings denoting specific features supported by the machine. An example is @code{"kvm"} for machines that have the KVM Linux modules and corresponding hardware support. Derivations can request features by @@ -915,7 +944,7 @@ machines, since offloading works by invoking the @code{guix archive} and this is the case by running: @example -lsh build-machine guile -c "'(use-modules (guix config))'" +ssh build-machine guile -c "'(use-modules (guix config))'" @end example There is one last thing to do once @file{machines.scm} is in place. As diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 33d141e7ef..327c99dfea 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -17,6 +17,10 @@ ;;; along with GNU Guix. If not, see . (define-module (guix scripts offload) + #:use-module (ssh key) + #:use-module (ssh auth) + #:use-module (ssh session) + #:use-module (ssh channel) #:use-module (guix config) #:use-module (guix records) #:use-module (guix store) @@ -65,14 +69,13 @@ (define-record-type* (system build-machine-system) ; string (user build-machine-user) ; string (private-key build-machine-private-key ; file name - (default (user-lsh-private-key))) + (default (user-openssh-private-key))) + (host-key build-machine-host-key) ; string (parallel-builds build-machine-parallel-builds ; number (default 1)) (speed build-machine-speed ; inexact real (default 1.0)) (features build-machine-features ; list of strings - (default '())) - (ssh-options build-machine-ssh-options ; list of strings (default '()))) (define-record-type* @@ -86,19 +89,11 @@ (define %machine-file ;; File that lists machines available as build slaves. (string-append %config-directory "/machines.scm")) -(define %lsh-command - "lsh") - -(define %lshg-command - ;; FIXME: 'lshg' fails to pass large amounts of data, see - ;; . - "lsh") - -(define (user-lsh-private-key) - "Return the user's default lsh private key, or #f if it could not be +(define (user-openssh-private-key) + "Return the user's default SSH private key, or #f if it could not be determined." (and=> (getenv "HOME") - (cut string-append <> "/.lsh/identity"))) + (cut string-append <> "/.ssh/id_rsa"))) (define %user-module ;; Module in which the machine description file is loaded. @@ -134,60 +129,79 @@ (define* (build-machines #:optional (file %machine-file)) (leave (_ "failed to load machine file '~a': ~s~%") file args)))))) -;;; FIXME: The idea was to open the connection to MACHINE once for all, but -;;; lshg is currently non-functional. -;; (define (open-ssh-gateway machine) -;; "Initiate an SSH connection gateway to MACHINE, and return the PID of the -;; running lsh gateway upon success, or #f on failure." -;; (catch 'system-error -;; (lambda () -;; (let* ((port (open-pipe* OPEN_READ %lsh-command -;; "-l" (build-machine-user machine) -;; "-i" (build-machine-private-key machine) -;; ;; XXX: With lsh 2.1, passing '--write-pid' -;; ;; last causes the PID not to be printed. -;; "--write-pid" "--gateway" "--background" -;; (build-machine-name machine))) -;; (line (read-line port)) -;; (status (close-pipe port))) -;; (if (zero? status) -;; (let ((pid (string->number line))) -;; (if (integer? pid) -;; pid -;; (begin -;; (warning (_ "'~a' did not write its PID on stdout: ~s~%") -;; %lsh-command line) -;; #f))) -;; (begin -;; (warning (_ "failed to initiate SSH connection to '~a':\ -;; '~a' exited with ~a~%") -;; (build-machine-name machine) -;; %lsh-command -;; (status:exit-val status)) -;; #f)))) -;; (lambda args -;; (leave (_ "failed to execute '~a': ~a~%") -;; %lsh-command (strerror (system-error-errno args)))))) - -(define-syntax with-error-to-port - (syntax-rules () - ((_ port exp0 exp ...) - (let ((new port) - (old (current-error-port))) - (dynamic-wind - (lambda () - (set-current-error-port new)) - (lambda () - exp0 exp ...) - (lambda () - (set-current-error-port old))))))) - -(define* (remote-pipe machine mode command - #:key (error-port (current-error-port)) (quote? #t)) - "Run COMMAND (a string list) on MACHINE, assuming an lsh gateway has been -set up. When QUOTE? is true, perform shell-quotation of all the elements of -COMMAND. Return either a pipe opened with MODE, or #f if the lsh client could -not be started." +(define (host-key->type+key host-key) + "Destructure HOST-KEY, an OpenSSH host key string, and return two values: +its key type as a symbol, and the actual base64-encoded string." + (define (type->symbol type) + (and (string-prefix? "ssh-" type) + (string->symbol (string-drop type 4)))) + + (match (string-tokenize host-key) + ((type key _) + (values (type->symbol type) key)) + ((type key) + (values (type->symbol type) key)))) + +(define (private-key-from-file* file) + "Like 'private-key-from-file', but raise an error that 'with-error-handling' +can interpret meaningfully." + (catch 'guile-ssh-error + (lambda () + (private-key-from-file file)) + (lambda (key proc str . rest) + (raise (condition + (&message (message (format #f (_ "failed to load SSH \ +private key from '~a': ~a") + file str)))))))) + +(define (open-ssh-session machine) + "Open an SSH session for MACHINE and return it. Throw an error on failure." + (let ((private (private-key-from-file* (build-machine-private-key machine))) + (public (public-key-from-file + (string-append (build-machine-private-key machine) + ".pub"))) + (session (make-session #:user (build-machine-user machine) + #:host (build-machine-name machine) + #:port (build-machine-port machine) + #:timeout 5 ;seconds + ;; #:log-verbosity 'protocol + #:identity (build-machine-private-key machine) + + ;; We need lightweight compression when + ;; exchanging full archives. + #:compression "zlib" + #:compression-level 3))) + (connect! session) + + ;; Authenticate the server. XXX: Guile-SSH 0.10.1 doesn't know about + ;; ed25519 keys and 'get-key-type' returns #f in that case. + (let-values (((server) (get-server-public-key session)) + ((type key) (host-key->type+key + (build-machine-host-key machine)))) + (unless (and (or (not (get-key-type server)) + (eq? (get-key-type server) type)) + (string=? (public-key->string server) key)) + ;; Key mismatch: something's wrong. XXX: It could be that the server + ;; provided its Ed25519 key when we where expecting its RSA key. + (leave (_ "server at '~a' returned host key '~a' of type '~a' \ +instead of '~a' of type '~a'~%") + (build-machine-name machine) + (public-key->string server) (get-key-type server) + key type))) + + (let ((auth (userauth-public-key! session private))) + (unless (eq? 'success auth) + (disconnect! session) + (leave (_ "SSH public key authentication failed for '~a': ~a~%") + (build-machine-name machine) (get-error session)))) + + session)) + +(define* (remote-pipe machine command + #:key (quote? #t)) + "Run COMMAND (a list) on MACHINE, and return an open input/output port, +which is also an SSH channel. When QUOTE? is true, perform shell-quotation of +all the elements of COMMAND." (define (shell-quote str) ;; Sort-of shell-quote STR so it can be passed as an argument to the ;; shell. @@ -195,20 +209,15 @@ (define (shell-quote str) (lambda () (write str)))) - ;; Let the child inherit ERROR-PORT. - (with-error-to-port error-port - (apply open-pipe* mode %lshg-command - "-l" (build-machine-user machine) - "-p" (number->string (build-machine-port machine)) - - ;; XXX: Remove '-i' when %LSHG-COMMAND really is lshg. - "-i" (build-machine-private-key machine) - - (append (build-machine-ssh-options machine) - (list (build-machine-name machine)) - (if quote? - (map shell-quote command) - command))))) + ;; TODO: Use (ssh popen) instead. + (let* ((session (open-ssh-session machine)) + (channel (make-channel session))) + (channel-open-session channel) + (channel-request-exec channel + (string-join (if quote? + (map shell-quote command) + command))) + channel)) ;;; @@ -335,10 +344,11 @@ (define script (unless (= EEXIST (system-error-errno args)) (apply throw args))))))) - (let ((pipe (remote-pipe machine OPEN_READ + (let ((pipe (remote-pipe machine `("guile" "-c" ,(object->string script))))) (read-string pipe) - (let ((status (close-pipe pipe))) + (let ((status (channel-get-exit-status pipe))) + (close-port pipe) (unless (zero? status) ;; Better be safe than sorry: if we ignore the error here, then FILE ;; may be GC'd just before we start using it. @@ -367,10 +377,10 @@ (define script (false-if-exception (delete-file file))) roots))))) - (let ((pipe (remote-pipe machine OPEN_READ + (let ((pipe (remote-pipe machine `("guile" "-c" ,(object->string script))))) (read-string pipe) - (close-pipe pipe))) + (close-port pipe))) (define* (offload drv machine #:key print-build-trace? (max-silent-time 3600) @@ -384,7 +394,7 @@ (define* (offload drv machine ;; Normally DRV has already been protected from GC when it was transferred. ;; The '-r' flag below prevents the build result from being GC'd. - (let ((pipe (remote-pipe machine OPEN_READ + (let ((pipe (remote-pipe machine `("guix" "build" "-r" ,%gc-root-file ,(format #f "--max-silent-time=~a" @@ -397,14 +407,20 @@ (define* (offload drv machine ;; Since 'guix build' writes the build log to its ;; stderr, everything will go directly to LOG-PORT. - #:error-port log-port))) + ;; #:error-port log-port ;; FIXME + ))) + ;; Make standard error visible. + (channel-set-stream! pipe 'stderr) + (let loop ((line (read-line pipe))) (unless (eof-object? line) (display line log-port) (newline log-port) (loop (read-line pipe)))) - (close-pipe pipe))) + (let loop ((status (channel-get-exit-status pipe))) + (close-port pipe) + status))) (define* (transfer-and-offload drv machine #:key @@ -438,7 +454,7 @@ (define* (transfer-and-offload drv machine with exit code ~a~%" (derivation-file-name drv) (build-machine-name machine) - (status:exit-val status)) + status) ;; Use exit code 100 for a permanent build failure. The daemon ;; interprets other non-zero codes as transient build failures. @@ -448,24 +464,14 @@ (define (send-files files machine) "Send the subset of FILES that's missing to MACHINE's store. Return #t on success, #f otherwise." (define (missing-files files) - ;; Return the subset of FILES not already on MACHINE. - (let*-values (((files) - (format #f "~{~a~%~}" files)) - ((missing pids) - (filtered-port - (append (list (which %lshg-command) - "-l" (build-machine-user machine) - "-p" (number->string - (build-machine-port machine)) - "-i" (build-machine-private-key machine)) - (build-machine-ssh-options machine) - (cons (build-machine-name machine) - '("guix" "archive" "--missing"))) - (open-input-string files))) - ((result) - (read-string missing))) - (for-each waitpid pids) - (string-tokenize result))) + ;; Return the subset of FILES not already on MACHINE. Use 'head' as a + ;; hack to make sure the remote end stops reading when we're done. + (let* ((pipe (remote-pipe machine + `("guix" "archive" "--missing") + #:quote? #f))) + (format pipe "~{~a~%~}" files) + (channel-send-eof pipe) + (string-tokenize (read-string pipe)))) (with-store store (guard (c ((nix-protocol-error? c) @@ -476,40 +482,28 @@ (define (missing-files files) ;; Compute the subset of FILES missing on MACHINE, and send them in ;; topologically sorted order so that they can actually be imported. - ;; - ;; To reduce load on the machine that's offloading (since it's typically - ;; already quite busy, see hydra.gnu.org), compress with gzip rather - ;; than xz: For a compression ratio 2 times larger, it is 20 times - ;; faster. (let* ((files (missing-files (topologically-sorted store files))) - (pipe (remote-pipe machine OPEN_WRITE - '("gzip" "-dc" "|" - "guix" "archive" "--import") + (pipe (remote-pipe machine + '("guix" "archive" "--import") #:quote? #f))) (format #t (_ "sending ~a store files to '~a'...~%") (length files) (build-machine-name machine)) - (call-with-compressed-output-port 'gzip pipe - (lambda (compressed) - (catch 'system-error - (lambda () - (export-paths store files compressed)) - (lambda args - (warning (_ "failed while exporting files to '~a': ~a~%") - (build-machine-name machine) - (strerror (system-error-errno args)))))) - #:options '("--fast")) - - ;; Wait for the 'lsh' process to complete. - (zero? (close-pipe pipe)))))) + + (export-paths store files pipe) + (channel-send-eof pipe) + + ;; Wait for the remote process to complete. + (let ((status (channel-get-exit-status pipe))) + (close pipe) + status))))) (define (retrieve-files files machine) "Retrieve FILES from MACHINE's store, and import them." (define host (build-machine-name machine)) - (let ((pipe (remote-pipe machine OPEN_READ - `("guix" "archive" "--export" ,@files - "|" "xz" "-c") + (let ((pipe (remote-pipe machine + `("guix" "archive" "--export" ,@files) #:quote? #f))) (and pipe (with-store store @@ -522,14 +516,11 @@ (define host ;; We cannot use the 'import-paths' RPC here because we already ;; hold the locks for FILES. - (call-with-decompressed-port 'xz pipe - (lambda (decompressed) - (restore-file-set decompressed - #:log-port (current-error-port) - #:lock? #f))) + (restore-file-set pipe + #:log-port (current-error-port) + #:lock? #f) - ;; Wait for the 'lsh' process to complete. - (zero? (close-pipe pipe))))))) + (close-port pipe)))))) ;;; @@ -547,13 +538,9 @@ (define (machine-matches? machine requirements) (define (machine-load machine) "Return the load of MACHINE, divided by the number of parallel builds allowed on MACHINE." - (let* ((pipe (remote-pipe machine OPEN_READ `("cat" "/proc/loadavg"))) - (line (read-line pipe)) - (status (close-pipe pipe))) - (unless (eqv? 0 (status:exit-val status)) - (warning (_ "failed to obtain load of '~a': SSH client exited with ~a~%") - (build-machine-name machine) - (status:exit-val status))) + (let* ((pipe (remote-pipe machine '("cat" "/proc/loadavg"))) + (line (read-line pipe))) + (close-port pipe) (if (eof-object? line) +inf.0 ;MACHINE does not respond, so assume it is infinitely loaded diff --git a/m4/guix.m4 b/m4/guix.m4 index 6d8ec2e4e0..6630598416 100644 --- a/m4/guix.m4 +++ b/m4/guix.m4 @@ -171,6 +171,24 @@ AC_DEFUN([GUIX_CHECK_UNBUFFERED_CBIP], [ fi]) ]) +dnl GUIX_CHECK_GUILE_SSH +dnl +dnl Check whether a recent-enough Guile-SSH is available. +AC_DEFUN([GUIX_CHECK_GUILE_SSH], [ + dnl Check whether 'channel-send-eof' (introduced in 0.10.2) is present. + AC_CACHE_CHECK([whether Guile-SSH is available and recent enough], + [guix_cv_have_recent_guile_ssh], + [GUILE_CHECK([retval], + [(and (@ (ssh channel) channel-send-eof) + (@ (ssh popen) open-remote-pipe) + (@ (ssh dist node) node-eval))]) + if test "$retval" = 0; then + guix_cv_have_recent_guile_ssh="yes" + else + guix_cv_have_recent_guile_ssh="no" + fi]) +]) + dnl GUIX_TEST_ROOT_DIRECTORY AC_DEFUN([GUIX_TEST_ROOT_DIRECTORY], [ AC_CACHE_CHECK([for unit test root directory], -- cgit v1.2.3 From 9e76eed37fc4cb0f70c1cc1441dfba92b25c33eb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 2 Nov 2016 12:00:47 +0100 Subject: offload: Reuse SSH session during 'transfer-and-offload'. * guix/scripts/offload.scm (remote-pipe): Replace 'machine' parameter with 'session'. Remove 'open-ssh-session' call. (register-gc-root): Replace 'machine' with 'session'. Use ' session-get' instead of 'build-machine-name'. (remove-gc-roots, offload, send-files, retrieve-files): Likewise. (transfer-and-offload): Add 'open-ssh-session' call. Handle 'offload' errors here. (machine-load): Add call to 'open-ssh-session'. --- guix/scripts/offload.scm | 84 +++++++++++++++++++++++++----------------------- 1 file changed, 43 insertions(+), 41 deletions(-) (limited to 'guix') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 327c99dfea..8704743a7f 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -197,9 +197,9 @@ (define (open-ssh-session machine) session)) -(define* (remote-pipe machine command +(define* (remote-pipe session command #:key (quote? #t)) - "Run COMMAND (a list) on MACHINE, and return an open input/output port, + "Run COMMAND (a list) on SESSION, and return an open input/output port, which is also an SSH channel. When QUOTE? is true, perform shell-quotation of all the elements of COMMAND." (define (shell-quote str) @@ -209,9 +209,7 @@ (define (shell-quote str) (lambda () (write str)))) - ;; TODO: Use (ssh popen) instead. - (let* ((session (open-ssh-session machine)) - (channel (make-channel session))) + (let* ((channel (make-channel session))) (channel-open-session channel) (channel-request-exec channel (string-join (if quote? @@ -312,8 +310,9 @@ (define %gc-root-file ;; File name of the temporary GC root we install. (format #f "offload-~a-~a" (gethostname) (getpid))) -(define (register-gc-root file machine) - "Mark FILE, a store item, as a garbage collector root on MACHINE." +(define (register-gc-root file session) + "Mark FILE, a store item, as a garbage collector root in SESSION. Return +the exit status, zero on success." (define script `(begin (use-modules (guix config)) @@ -344,7 +343,7 @@ (define script (unless (= EEXIST (system-error-errno args)) (apply throw args))))))) - (let ((pipe (remote-pipe machine + (let ((pipe (remote-pipe session `("guile" "-c" ,(object->string script))))) (read-string pipe) (let ((status (channel-get-exit-status pipe))) @@ -353,10 +352,10 @@ (define script ;; Better be safe than sorry: if we ignore the error here, then FILE ;; may be GC'd just before we start using it. (leave (_ "failed to register GC root for '~a' on '~a' (status: ~a)~%") - file (build-machine-name machine) status))))) + file (session-get session 'host) status))))) -(define (remove-gc-roots machine) - "Remove from MACHINE the GC roots previously installed with +(define (remove-gc-roots session) + "Remove in SESSION the GC roots previously installed with 'register-gc-root'." (define script `(begin @@ -377,24 +376,19 @@ (define script (false-if-exception (delete-file file))) roots))))) - (let ((pipe (remote-pipe machine + (let ((pipe (remote-pipe session `("guile" "-c" ,(object->string script))))) (read-string pipe) (close-port pipe))) -(define* (offload drv machine +(define* (offload drv session #:key print-build-trace? (max-silent-time 3600) build-timeout (log-port (build-log-port))) - "Perform DRV on MACHINE, assuming DRV and its prerequisites are available + "Perform DRV in SESSION, assuming DRV and its prerequisites are available there, and write the build log to LOG-PORT. Return the exit status." - (format (current-error-port) "offloading '~a' to '~a'...~%" - (derivation-file-name drv) (build-machine-name machine)) - (format (current-error-port) "@ build-remote ~a ~a~%" - (derivation-file-name drv) (build-machine-name machine)) - ;; Normally DRV has already been protected from GC when it was transferred. ;; The '-r' flag below prevents the build result from being GC'd. - (let ((pipe (remote-pipe machine + (let ((pipe (remote-pipe session `("guix" "build" "-r" ,%gc-root-file ,(format #f "--max-silent-time=~a" @@ -432,23 +426,31 @@ (define* (transfer-and-offload drv machine "Offload DRV to MACHINE. Prior to the actual offloading, transfer all of INPUTS to MACHINE; if building DRV succeeds, retrieve all of OUTPUTS from MACHINE." + (define session + (open-ssh-session machine)) + (when (begin - (register-gc-root (derivation-file-name drv) machine) + (register-gc-root (derivation-file-name drv) session) (send-files (cons (derivation-file-name drv) inputs) - machine)) - (let ((status (offload drv machine + session)) + (format (current-error-port) "offloading '~a' to '~a'...~%" + (derivation-file-name drv) (build-machine-name machine)) + (format (current-error-port) "@ build-remote ~a ~a~%" + (derivation-file-name drv) (build-machine-name machine)) + + (let ((status (offload drv session #:print-build-trace? print-build-trace? #:max-silent-time max-silent-time #:build-timeout build-timeout))) (if (zero? status) (begin - (retrieve-files outputs machine) - (remove-gc-roots machine) + (retrieve-files outputs session) + (remove-gc-roots session) (format (current-error-port) "done with offloaded '~a'~%" (derivation-file-name drv))) (begin - (remove-gc-roots machine) + (remove-gc-roots session) (format (current-error-port) "derivation '~a' offloaded to '~a' failed \ with exit code ~a~%" @@ -460,13 +462,13 @@ (define* (transfer-and-offload drv machine ;; interprets other non-zero codes as transient build failures. (primitive-exit 100)))))) -(define (send-files files machine) - "Send the subset of FILES that's missing to MACHINE's store. Return #t on +(define (send-files files session) + "Send the subset of FILES that's missing to SESSION's store. Return #t on success, #f otherwise." (define (missing-files files) - ;; Return the subset of FILES not already on MACHINE. Use 'head' as a + ;; Return the subset of FILES not already on SESSION. Use 'head' as a ;; hack to make sure the remote end stops reading when we're done. - (let* ((pipe (remote-pipe machine + (let* ((pipe (remote-pipe session `("guix" "archive" "--missing") #:quote? #f))) (format pipe "~{~a~%~}" files) @@ -476,18 +478,17 @@ (define (missing-files files) (with-store store (guard (c ((nix-protocol-error? c) (warning (_ "failed to export files for '~a': ~s~%") - (build-machine-name machine) - c) + (session-get session 'host) c) #f)) - ;; Compute the subset of FILES missing on MACHINE, and send them in + ;; Compute the subset of FILES missing on SESSION, and send them in ;; topologically sorted order so that they can actually be imported. (let* ((files (missing-files (topologically-sorted store files))) - (pipe (remote-pipe machine + (pipe (remote-pipe session '("guix" "archive" "--import") #:quote? #f))) (format #t (_ "sending ~a store files to '~a'...~%") - (length files) (build-machine-name machine)) + (length files) (session-get session 'host)) (export-paths store files pipe) (channel-send-eof pipe) @@ -497,12 +498,12 @@ (define (missing-files files) (close pipe) status))))) -(define (retrieve-files files machine) - "Retrieve FILES from MACHINE's store, and import them." +(define (retrieve-files files session) + "Retrieve FILES from SESSION's store, and import them." (define host - (build-machine-name machine)) + (session-get session 'host)) - (let ((pipe (remote-pipe machine + (let ((pipe (remote-pipe session `("guix" "archive" "--export" ,@files) #:quote? #f))) (and pipe @@ -538,8 +539,9 @@ (define (machine-matches? machine requirements) (define (machine-load machine) "Return the load of MACHINE, divided by the number of parallel builds allowed on MACHINE." - (let* ((pipe (remote-pipe machine '("cat" "/proc/loadavg"))) - (line (read-line pipe))) + (let* ((session (open-ssh-session machine)) + (pipe (remote-pipe session '("cat" "/proc/loadavg"))) + (line (read-line pipe))) (close-port pipe) (if (eof-object? line) -- cgit v1.2.3 From 6230d6f04f4bde9ad834f97c5c950db89dde0496 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 2 Nov 2016 22:50:31 +0100 Subject: store: 'open-connection' can taken an open port. * guix/store.scm (open-unix-domain-socket): New procedure. (open-connection): Add #:port parameter and honor it. --- guix/store.scm | 58 +++++++++++++++++++++++++++++++++------------------------- 1 file changed, 33 insertions(+), 25 deletions(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index 7f54b87db1..689a94c636 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -345,50 +345,58 @@ (define-condition-type &nix-protocol-error &nix-error (message nix-protocol-error-message) (status nix-protocol-error-status)) -(define* (open-connection #:optional (file (%daemon-socket-file)) - #:key (reserve-space? #t) cpu-affinity) - "Connect to the daemon over the Unix-domain socket at FILE. When -RESERVE-SPACE? is true, instruct it to reserve a little bit of extra space on -the file system so that the garbage collector can still operate, should the -disk become full. When CPU-AFFINITY is true, it must be an integer -corresponding to an OS-level CPU number to which the daemon's worker process -for this connection will be pinned. Return a server object." +(define (open-unix-domain-socket file) + "Connect to the Unix-domain socket at FILE and return it. Raise a +'&nix-connection-error' upon error." (let ((s (with-fluids ((%default-port-encoding #f)) ;; This trick allows use of the `scm_c_read' optimization. (socket PF_UNIX SOCK_STREAM 0))) (a (make-socket-address PF_UNIX file))) (catch 'system-error - (cut connect s a) + (lambda () + (connect s a) + s) (lambda args ;; Translate the error to something user-friendly. (let ((errno (system-error-errno args))) (raise (condition (&nix-connection-error (file file) - (errno errno))))))) + (errno errno))))))))) - (write-int %worker-magic-1 s) - (let ((r (read-int s))) +(define* (open-connection #:optional (file (%daemon-socket-file)) + #:key port (reserve-space? #t) cpu-affinity) + "Connect to the daemon over the Unix-domain socket at FILE, or, if PORT is +not #f, use it as the I/O port over which to communicate to a build daemon. + +When RESERVE-SPACE? is true, instruct it to reserve a little bit of extra +space on the file system so that the garbage collector can still operate, +should the disk become full. When CPU-AFFINITY is true, it must be an integer +corresponding to an OS-level CPU number to which the daemon's worker process +for this connection will be pinned. Return a server object." + (let ((port (or port (open-unix-domain-socket file)))) + (write-int %worker-magic-1 port) + (let ((r (read-int port))) (and (eqv? r %worker-magic-2) - (let ((v (read-int s))) + (let ((v (read-int port))) (and (eqv? (protocol-major %protocol-version) (protocol-major v)) (begin - (write-int %protocol-version s) + (write-int %protocol-version port) (when (>= (protocol-minor v) 14) - (write-int (if cpu-affinity 1 0) s) + (write-int (if cpu-affinity 1 0) port) (when cpu-affinity - (write-int cpu-affinity s))) + (write-int cpu-affinity port))) (when (>= (protocol-minor v) 11) - (write-int (if reserve-space? 1 0) s)) - (let ((s (%make-nix-server s - (protocol-major v) - (protocol-minor v) - (make-hash-table 100) - (make-hash-table 100)))) - (let loop ((done? (process-stderr s))) - (or done? (process-stderr s))) - s)))))))) + (write-int (if reserve-space? 1 0) port)) + (let ((conn (%make-nix-server port + (protocol-major v) + (protocol-minor v) + (make-hash-table 100) + (make-hash-table 100)))) + (let loop ((done? (process-stderr conn))) + (or done? (process-stderr conn))) + conn)))))))) (define (close-connection server) "Close the connection to SERVER." -- cgit v1.2.3 From e8a5db80d5fe2e603d7b72c3b3cc5ba6ea6d99d9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 5 Nov 2016 00:46:04 +0100 Subject: offload: Remove 'with-nar-error-handling' macro. * guix/scripts/offload.scm (with-nar-error-handling): Remove. (guix-offload): Use 'with-error-handling' instead. --- guix/scripts/offload.scm | 13 +------------ 1 file changed, 1 insertion(+), 12 deletions(-) (limited to 'guix') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 8704743a7f..35286ab9d5 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -664,17 +664,6 @@ (define* (process-request wants-local? system drv features ;; Not now, all the machines are busy. (display "# postpone\n"))))))) -(define-syntax-rule (with-nar-error-handling body ...) - "Execute BODY with any &nar-error suitably reported to the user." - (guard (c ((nar-error? c) - (let ((file (nar-error-file c))) - (if (condition-has-type? c &message) - (leave (_ "while importing file '~a': ~a~%") - file (gettext (condition-message c))) - (leave (_ "failed to import file '~a'~%") - file))))) - body ...)) - ;;; ;;; Entry point. @@ -705,7 +694,7 @@ (define not-coma (cond ((regexp-exec request-line-rx line) => (lambda (match) - (with-nar-error-handling + (with-error-handling (process-request (equal? (match:substring match 1) "1") (match:substring match 2) ; system (call-with-input-file -- cgit v1.2.3 From cf283dd92eb5ef2dee4b761bb23f6dca2525cd55 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 5 Nov 2016 00:47:34 +0100 Subject: offload: Rewrite to make direct RPCs to the remote daemon. * guix/scripts/offload.scm ()[daemon-socket]: New field. (connect-to-remote-daemon): New procedure. (%gc-root-file, register-gc-root, remove-gc-roots, offload): Remove. (transfer-and-offload): Rewrite using 'connect-to-remote-daemon' and RPCs over SSH. (store-import-channel, store-export-channel): New procedures. (send-files, retrieve-files): Rewrite using these. --- doc/guix.texi | 4 + guix/scripts/offload.scm | 371 ++++++++++++++++++++++------------------------- 2 files changed, 175 insertions(+), 200 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index f1cb007aa9..b8e37055e6 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -921,6 +921,10 @@ Port number of SSH server on the machine. The SSH private key file to use when connecting to the machine, in OpenSSH format. +@item @code{daemon-socket} (default: @code{"/var/guix/daemon-socket/socket"}) +File name of the Unix-domain socket @command{guix-daemon} is listening +to on that machine. + @item @code{parallel-builds} (default: @code{1}) The number of builds that may run in parallel on the machine. diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 35286ab9d5..1821bb5b7a 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -21,6 +21,9 @@ (define-module (guix scripts offload) #:use-module (ssh auth) #:use-module (ssh session) #:use-module (ssh channel) + #:use-module (ssh popen) + #:use-module (ssh dist) + #:use-module (ssh dist node) #:use-module (guix config) #:use-module (guix records) #:use-module (guix store) @@ -71,6 +74,8 @@ (define-record-type* (private-key build-machine-private-key ; file name (default (user-openssh-private-key))) (host-key build-machine-host-key) ; string + (daemon-socket build-machine-daemon-socket ; string + (default "/var/guix/daemon-socket/socket")) (parallel-builds build-machine-parallel-builds ; number (default 1)) (speed build-machine-speed ; inexact real @@ -197,6 +202,53 @@ (define (open-ssh-session machine) session)) +(define* (connect-to-remote-daemon session + #:optional + (socket-name "/var/guix/daemon-socket/socket")) + "Connect to the remote build daemon listening on SOCKET-NAME over SESSION, +an SSH session. Return a object." + (define redirect + ;; Code run in SESSION to redirect the remote process' stdin/stdout to the + ;; daemon's socket, à la socat. The SSH protocol supports forwarding to + ;; Unix-domain sockets but libssh doesn't have an API for that, hence this + ;; hack. + `(begin + (use-modules (ice-9 match) (rnrs io ports)) + + (let ((sock (socket AF_UNIX SOCK_STREAM 0)) + (stdin (current-input-port)) + (stdout (current-output-port))) + (setvbuf stdin _IONBF) + (setvbuf stdout _IONBF) + (connect sock AF_UNIX ,socket-name) + + (let loop () + (match (select (list stdin sock) '() (list stdin stdout sock)) + ((reads writes ()) + (when (memq stdin reads) + (match (get-bytevector-some stdin) + ((? eof-object?) + (primitive-exit 0)) + (bv + (put-bytevector sock bv)))) + (when (memq sock reads) + (match (get-bytevector-some sock) + ((? eof-object?) + (primitive-exit 0)) + (bv + (put-bytevector stdout bv)))) + (loop)) + (_ + (primitive-exit 1))))))) + + (let ((channel + (open-remote-pipe* session OPEN_BOTH + ;; Sort-of shell-quote REDIRECT. + "guile" "-c" + (object->string + (object->string redirect))))) + (open-connection #:port channel))) + (define* (remote-pipe session command #:key (quote? #t)) "Run COMMAND (a list) on SESSION, and return an open input/output port, @@ -306,116 +358,6 @@ (define (build-log-port) (set-port-revealed! port 1) port)) -(define %gc-root-file - ;; File name of the temporary GC root we install. - (format #f "offload-~a-~a" (gethostname) (getpid))) - -(define (register-gc-root file session) - "Mark FILE, a store item, as a garbage collector root in SESSION. Return -the exit status, zero on success." - (define script - `(begin - (use-modules (guix config)) - - ;; Note: we can't use 'add-indirect-root' because dangling links under - ;; gcroots/auto are automatically deleted by the GC. This strategy - ;; doesn't have this problem, but it requires write access to that - ;; directory. - (let ((root-directory (string-append %state-directory - "/gcroots/tmp"))) - (catch 'system-error - (lambda () - (mkdir root-directory)) - (lambda args - (unless (= EEXIST (system-error-errno args)) - (error "failed to create remote GC root directory" - root-directory (system-error-errno args))))) - - (catch 'system-error - (lambda () - (symlink ,file - (string-append root-directory "/" ,%gc-root-file))) - (lambda args - ;; If FILE already exists, we can assume that either it's a stale - ;; reference (which is fine), or another process is already - ;; building the derivation represented by FILE (which is fine - ;; too.) Thus, do nothing in that case. - (unless (= EEXIST (system-error-errno args)) - (apply throw args))))))) - - (let ((pipe (remote-pipe session - `("guile" "-c" ,(object->string script))))) - (read-string pipe) - (let ((status (channel-get-exit-status pipe))) - (close-port pipe) - (unless (zero? status) - ;; Better be safe than sorry: if we ignore the error here, then FILE - ;; may be GC'd just before we start using it. - (leave (_ "failed to register GC root for '~a' on '~a' (status: ~a)~%") - file (session-get session 'host) status))))) - -(define (remove-gc-roots session) - "Remove in SESSION the GC roots previously installed with -'register-gc-root'." - (define script - `(begin - (use-modules (guix config) (ice-9 ftw) - (srfi srfi-1) (srfi srfi-26)) - - (let ((root-directory (string-append %state-directory - "/gcroots/tmp"))) - (false-if-exception - (delete-file - (string-append root-directory "/" ,%gc-root-file))) - - ;; These ones were created with 'guix build -r' (there can be more - ;; than one in case of multiple-output derivations.) - (let ((roots (filter (cut string-prefix? ,%gc-root-file <>) - (scandir ".")))) - (for-each (lambda (file) - (false-if-exception (delete-file file))) - roots))))) - - (let ((pipe (remote-pipe session - `("guile" "-c" ,(object->string script))))) - (read-string pipe) - (close-port pipe))) - -(define* (offload drv session - #:key print-build-trace? (max-silent-time 3600) - build-timeout (log-port (build-log-port))) - "Perform DRV in SESSION, assuming DRV and its prerequisites are available -there, and write the build log to LOG-PORT. Return the exit status." - ;; Normally DRV has already been protected from GC when it was transferred. - ;; The '-r' flag below prevents the build result from being GC'd. - (let ((pipe (remote-pipe session - `("guix" "build" - "-r" ,%gc-root-file - ,(format #f "--max-silent-time=~a" - max-silent-time) - ,@(if build-timeout - (list (format #f "--timeout=~a" - build-timeout)) - '()) - ,(derivation-file-name drv)) - - ;; Since 'guix build' writes the build log to its - ;; stderr, everything will go directly to LOG-PORT. - ;; #:error-port log-port ;; FIXME - ))) - ;; Make standard error visible. - (channel-set-stream! pipe 'stderr) - - (let loop ((line (read-line pipe))) - (unless (eof-object? line) - (display line log-port) - (newline log-port) - (loop (read-line pipe)))) - - (let loop ((status (channel-get-exit-status pipe))) - (close-port pipe) - status))) - (define* (transfer-and-offload drv machine #:key (inputs '()) @@ -429,99 +371,128 @@ (define* (transfer-and-offload drv machine (define session (open-ssh-session machine)) - (when (begin - (register-gc-root (derivation-file-name drv) session) - (send-files (cons (derivation-file-name drv) inputs) - session)) - (format (current-error-port) "offloading '~a' to '~a'...~%" - (derivation-file-name drv) (build-machine-name machine)) - (format (current-error-port) "@ build-remote ~a ~a~%" - (derivation-file-name drv) (build-machine-name machine)) - - (let ((status (offload drv session - #:print-build-trace? print-build-trace? - #:max-silent-time max-silent-time - #:build-timeout build-timeout))) - (if (zero? status) - (begin - (retrieve-files outputs session) - (remove-gc-roots session) - (format (current-error-port) - "done with offloaded '~a'~%" - (derivation-file-name drv))) - (begin - (remove-gc-roots session) - (format (current-error-port) - "derivation '~a' offloaded to '~a' failed \ -with exit code ~a~%" - (derivation-file-name drv) - (build-machine-name machine) - status) - - ;; Use exit code 100 for a permanent build failure. The daemon - ;; interprets other non-zero codes as transient build failures. - (primitive-exit 100)))))) - -(define (send-files files session) - "Send the subset of FILES that's missing to SESSION's store. Return #t on -success, #f otherwise." - (define (missing-files files) - ;; Return the subset of FILES not already on SESSION. Use 'head' as a - ;; hack to make sure the remote end stops reading when we're done. - (let* ((pipe (remote-pipe session - `("guix" "archive" "--missing") - #:quote? #f))) - (format pipe "~{~a~%~}" files) - (channel-send-eof pipe) - (string-tokenize (read-string pipe)))) + (define store + (connect-to-remote-daemon session + (build-machine-daemon-socket machine))) + + (set-build-options store + #:print-build-trace print-build-trace? + #:max-silent-time max-silent-time + #:timeout build-timeout) + + ;; Protect DRV from garbage collection. + (add-temp-root store (derivation-file-name drv)) + + (send-files (cons (derivation-file-name drv) inputs) + store) + (format (current-error-port) "offloading '~a' to '~a'...~%" + (derivation-file-name drv) (build-machine-name machine)) + (format (current-error-port) "@ build-remote ~a ~a~%" + (derivation-file-name drv) (build-machine-name machine)) + + (guard (c ((nix-protocol-error? c) + (format (current-error-port) + (_ "derivation '~a' offloaded to '~a' failed: ~a~%") + (derivation-file-name drv) + (build-machine-name machine) + (nix-protocol-error-message c)) + ;; Use exit code 100 for a permanent build failure. The daemon + ;; interprets other non-zero codes as transient build failures. + (primitive-exit 100))) + (build-derivations store (list drv))) + + (retrieve-files outputs store) + (format (current-error-port) "done with offloaded '~a'~%" + (derivation-file-name drv))) + +(define (store-import-channel session) + "Return an output port to which archives to be exported to SESSION's store +can be written." + ;; Using the 'import-paths' RPC on a remote store would be slow because it + ;; makes a round trip every time 32 KiB have been transferred. This + ;; procedure instead opens a separate channel to use the remote + ;; 'import-paths' procedure, which consumes all the data in a single round + ;; trip. + (define import + `(begin + (use-modules (guix)) + + (with-store store + (setvbuf (current-input-port) _IONBF) + (import-paths store (current-input-port))))) + + (open-remote-output-pipe session + (string-join + `("guile" "-c" + ,(object->string + (object->string import)))))) + +(define (store-export-channel session files) + "Return an input port from which an export of FILES from SESSION's store can +be read." + ;; Same as above: this is more efficient than calling 'export-paths' on a + ;; remote store. + (define export + `(begin + (use-modules (guix)) + + (with-store store + (setvbuf (current-output-port) _IONBF) + (export-paths store ',files (current-output-port))))) + + (open-remote-input-pipe session + (string-join + `("guile" "-c" + ,(object->string + (object->string export)))))) +(define (send-files files remote) + "Send the subset of FILES that's missing to REMOTE, a remote store." (with-store store - (guard (c ((nix-protocol-error? c) - (warning (_ "failed to export files for '~a': ~s~%") - (session-get session 'host) c) - #f)) - - ;; Compute the subset of FILES missing on SESSION, and send them in - ;; topologically sorted order so that they can actually be imported. - (let* ((files (missing-files (topologically-sorted store files))) - (pipe (remote-pipe session - '("guix" "archive" "--import") - #:quote? #f))) - (format #t (_ "sending ~a store files to '~a'...~%") - (length files) (session-get session 'host)) - - (export-paths store files pipe) - (channel-send-eof pipe) - - ;; Wait for the remote process to complete. - (let ((status (channel-get-exit-status pipe))) - (close pipe) - status))))) - -(define (retrieve-files files session) + ;; Compute the subset of FILES missing on SESSION, and send them in + ;; topologically sorted order so that they can actually be imported. + (let* ((sorted (topologically-sorted store files)) + (session (channel-get-session (nix-server-socket remote))) + (node (make-node session)) + (missing (node-eval node + `(begin + (use-modules (guix) + (srfi srfi-1) (srfi srfi-26)) + + (with-store store + (remove (cut valid-path? store <>) + ',sorted))))) + (port (store-import-channel session))) + (format #t (_ "sending ~a store files to '~a'...~%") + (length missing) (session-get session 'host)) + + (export-paths store missing port) + + ;; Tell the remote process that we're done. (In theory the + ;; end-of-archive mark of 'export-paths' would be enough, but in + ;; practice it's not.) + (channel-send-eof port) + + ;; Wait for completion of the remote process. + (let ((result (zero? (channel-get-exit-status port)))) + (close-port port) + result)))) + +(define (retrieve-files files remote) "Retrieve FILES from SESSION's store, and import them." - (define host - (session-get session 'host)) - - (let ((pipe (remote-pipe session - `("guix" "archive" "--export" ,@files) - #:quote? #f))) - (and pipe - (with-store store - (guard (c ((nix-protocol-error? c) - (warning (_ "failed to import files from '~a': ~s~%") - host c) - #f)) - (format (current-error-port) "retrieving ~a files from '~a'...~%" - (length files) host) - - ;; We cannot use the 'import-paths' RPC here because we already - ;; hold the locks for FILES. - (restore-file-set pipe - #:log-port (current-error-port) - #:lock? #f) - - (close-port pipe)))))) + (let* ((session (channel-get-session (nix-server-socket remote))) + (host (session-get session 'host)) + (port (store-export-channel session files))) + (format #t (_ "retrieving ~a files from '~a'...~%") + (length files) host) + + ;; We cannot use the 'import-paths' RPC here because we already + ;; hold the locks for FILES. + (let ((result (restore-file-set port + #:log-port (current-error-port) + #:lock? #f))) + (close-port port) + result))) ;;; -- cgit v1.2.3 From bc1ad4e334fbf5239ed8d617751e9fa7dbe0ab23 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 25 Nov 2016 22:47:37 +0100 Subject: offload: Drop 'remote-pipe'. * guix/scripts/offload.scm (remote-pipe): Remove. (machine-load): Use 'open-remote-pipe*' instead of 'remote-pipe'. --- guix/scripts/offload.scm | 23 ++--------------------- 1 file changed, 2 insertions(+), 21 deletions(-) (limited to 'guix') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 1821bb5b7a..2e0268020c 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -249,26 +249,6 @@ (define redirect (object->string redirect))))) (open-connection #:port channel))) -(define* (remote-pipe session command - #:key (quote? #t)) - "Run COMMAND (a list) on SESSION, and return an open input/output port, -which is also an SSH channel. When QUOTE? is true, perform shell-quotation of -all the elements of COMMAND." - (define (shell-quote str) - ;; Sort-of shell-quote STR so it can be passed as an argument to the - ;; shell. - (with-output-to-string - (lambda () - (write str)))) - - (let* ((channel (make-channel session))) - (channel-open-session channel) - (channel-request-exec channel - (string-join (if quote? - (map shell-quote command) - command))) - channel)) - ;;; ;;; Synchronization. @@ -511,7 +491,8 @@ (define (machine-load machine) "Return the load of MACHINE, divided by the number of parallel builds allowed on MACHINE." (let* ((session (open-ssh-session machine)) - (pipe (remote-pipe session '("cat" "/proc/loadavg"))) + (pipe (open-remote-pipe* session OPEN_READ + "cat" "/proc/loadavg")) (line (read-line pipe))) (close-port pipe) -- cgit v1.2.3 From 1cd1d8a7ea43bfb99aa05c74da5430bb3d8a4309 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 26 Nov 2016 23:00:36 +0100 Subject: offload: Call 'machine-load' only once per machine. This fixes a longstanding issue where 'choose-build-machine' would make on average O(N log(N)) calls to 'machine-load', plus an extra call for the selected machine, instead of N calls. * guix/scripts/offload.scm (machine-load): Add comment. (machine-power-factor, machine-less-loaded-or-faster?): Remove. (choose-build-machine)[machines+slots]: Rename to... [machines+slots+loads]: ... this. [undecorate]: Adjust accordingly. [machine-less-loaded-or-faster?]: New procedure. Remove extra 'machine-load' call in body. --- guix/scripts/offload.scm | 46 +++++++++++++++++++++++----------------------- 1 file changed, 23 insertions(+), 23 deletions(-) (limited to 'guix') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 2e0268020c..bc024a8701 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -490,6 +490,7 @@ (define (machine-matches? machine requirements) (define (machine-load machine) "Return the load of MACHINE, divided by the number of parallel builds allowed on MACHINE." + ;; Note: This procedure is costly since it creates a new SSH session. (let* ((session (open-ssh-session machine)) (pipe (open-remote-pipe* session OPEN_READ "cat" "/proc/loadavg")) @@ -510,17 +511,6 @@ (define (machine-load machine) (_ +inf.0))))) ;something's fishy about MACHINE, so avoid it -(define (machine-power-factor m) - "Return a factor that aggregates the speed and load of M. The higher the -better." - (/ (build-machine-speed m) - (+ 1 (machine-load m)))) - -(define (machine-less-loaded-or-faster? m1 m2) - "Return #t if M1 is either less loaded or faster than M2. (This relation -defines a total order on machines.)" - (> (machine-power-factor m1) (machine-power-factor m2))) - (define (machine-lock-file machine hint) "Return the name of MACHINE's lock file for HINT." (string-append %state-directory "/offload/" @@ -548,29 +538,39 @@ (define (choose-build-machine machines) ;; 5. Release the global machine-choice lock. (with-file-lock (machine-choice-lock-file) - (define machines+slots + (define machines+slots+loads (filter-map (lambda (machine) + ;; Call 'machine-load' from here to make sure it is called + ;; only once per machine (it is expensive). (let ((slot (acquire-build-slot machine))) - (and slot (list machine slot)))) + (and slot + (list machine slot (machine-load machine))))) machines)) (define (undecorate pred) (lambda (a b) (match a - ((machine1 slot1) + ((machine1 slot1 load1) (match b - ((machine2 slot2) - (pred machine1 machine2))))))) - - (let loop ((machines+slots - (sort machines+slots + ((machine2 slot2 load2) + (pred machine1 load1 machine2 load2))))))) + + (define (machine-less-loaded-or-faster? m1 l1 m2 l2) + ;; Return #t if M1 is either less loaded or faster than M2, with L1 + ;; being the load of M1 and L2 the load of M2. (This relation defines a + ;; total order on machines.) + (> (/ (build-machine-speed m1) (+ 1 l1)) + (/ (build-machine-speed m2) (+ 1 l2)))) + + (let loop ((machines+slots+loads + (sort machines+slots+loads (undecorate machine-less-loaded-or-faster?)))) - (match machines+slots - (((best slot) others ...) + (match machines+slots+loads + (((best slot load) others ...) ;; Return the best machine unless it's already overloaded. - (if (< (machine-load best) 2.) + (if (< load 2.) (match others - (((machines slots) ...) + (((machines slots loads) ...) ;; Release slots from the uninteresting machines. (for-each release-build-slot slots) -- cgit v1.2.3 From c062b1eb6c9d799f0015e26b14cd77eaf8d946dd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 28 Nov 2016 22:08:17 +0100 Subject: pull: Set '%nix-instantiate' to a sensible value. Reported by ng0 . Fixes . * guix/build/pull.scm (build-guix): Replace "@NIX_INSTANTIATE@" in guix/config.scm with "nix-instantiate". --- guix/build/pull.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/pull.scm b/guix/build/pull.scm index 871bf6f535..6034e93cbf 100644 --- a/guix/build/pull.scm +++ b/guix/build/pull.scm @@ -84,7 +84,7 @@ (define* (build-guix out source (("@GZIP@") (string-append gzip "/bin/gzip")) (("@BZIP2@") (string-append bzip2 "/bin/bzip2")) (("@XZ@") (string-append xz "/bin/xz")) - (("@NIX_INSTANTIATE@") "")) ;remnants from the past + (("@NIX_INSTANTIATE@") "nix-instantiate")) ;for (guix import nix) ;; Augment the search path so Scheme code can be compiled. (set! %load-path (cons out %load-path)) -- cgit v1.2.3 From e9c72306fdfd6a60158918850cb25d0ff3837d16 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 29 Nov 2016 15:07:07 +0100 Subject: refresh: Warn about packages that lack an updater. * guix/upstream.scm (package-update-path): Rename to... (package-latest-release): ... this. Remove 'version>?' check. (package-latest-release*): New procedure. (package-update): Use it. * guix/scripts/refresh.scm (lookup-updater): Rename to... (lookup-updater-by-name): ... this. (warn-no-updater): New procedure. (update-package): Add #:warn? parameter and honor it. (check-for-package-update): New procedure. (guix-refresh)[warn?]: New variable. Replace inline code when UPDATE? is false with a call to 'check-for-package-update'. Pass WARN? to 'check-for-package-update' and 'update-package'. * doc/guix.texi (Invoking guix refresh): Document it. Fix a couple of typos. --- doc/guix.texi | 19 +++++++--- guix/scripts/refresh.scm | 96 ++++++++++++++++++++++++++++++------------------ guix/upstream.scm | 30 ++++++++++----- 3 files changed, 95 insertions(+), 50 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index ce1e5d075a..4677e5cf79 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5250,10 +5250,19 @@ gnu/packages/gettext.scm:29:13: gettext would be upgraded from 0.18.1.1 to 0.18. gnu/packages/glib.scm:77:12: glib would be upgraded from 2.34.3 to 2.37.0 @end example -It does so by browsing the FTP directory of each package and determining -the highest version number of the source tarballs therein. The command +Alternately, one can specify packages to consider, in which case a +warning is emitted for packages that lack an updater: + +@example +$ guix refresh coreutils guile guile-ssh +gnu/packages/ssh.scm:205:2: warning: no updater for guile-ssh +gnu/packages/guile.scm:136:12: guile would be upgraded from 2.0.12 to 2.0.13 +@end example + +@command{guix refresh} browses the upstream repository of each package and determines +the highest version number of the releases therein. The command knows how to update specific types of packages: GNU packages, ELPA -packages, etc.---see the documentation for @option{--type} below. The +packages, etc.---see the documentation for @option{--type} below. There 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! @@ -5293,7 +5302,7 @@ usually run from a checkout of the Guix source tree (@pxref{Running Guix Before It Is Installed}): @example -$ ./pre-inst-env guix refresh -s non-core +$ ./pre-inst-env guix refresh -s non-core -u @end example @xref{Defining Packages}, for more information on package definitions. @@ -5359,7 +5368,7 @@ In addition, @command{guix refresh} can be passed one or more package names, as in this example: @example -$ ./pre-inst-env guix refresh -u emacs idutils gcc-4.8.4 +$ ./pre-inst-env guix refresh -u emacs idutils gcc@@4.8 @end example @noindent diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index b81c69f9fe..ed28ed5fcb 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -208,7 +208,7 @@ (define %updaters ((guix import gem) => %gem-updater) ((guix import github) => %github-updater))) -(define (lookup-updater name) +(define (lookup-updater-by-name name) "Return the updater called NAME." (or (find (lambda (updater) (eq? name (upstream-updater-name updater))) @@ -225,31 +225,60 @@ (define (list-updaters-and-exit) %updaters) (exit 0)) +(define (warn-no-updater package) + (format (current-error-port) + (_ "~a: warning: no updater for ~a~%") + (location->string (package-location package)) + (package-name package))) + (define* (update-package store package updaters - #:key (key-download 'interactive)) + #:key (key-download 'interactive) warn?) "Update the source file that defines PACKAGE with the new version. KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed -values: 'interactive' (default), 'always', and 'never'." - (let-values (((version tarball) - (package-update store package updaters - #:key-download key-download)) - ((loc) - (or (package-field-location package 'version) - (package-location package)))) - (when version - (if (and=> tarball file-exists?) - (begin - (format (current-error-port) - (_ "~a: ~a: updating from version ~a to version ~a...~%") - (location->string loc) - (package-name package) - (package-version package) version) - (let ((hash (call-with-input-file tarball - port-sha256))) - (update-package-source package version hash))) - (warning (_ "~a: version ~a could not be \ +values: 'interactive' (default), 'always', and 'never'. When WARN? is true, +warn about packages that have no matching updater." + (if (lookup-updater package updaters) + (let-values (((version tarball) + (package-update store package updaters + #:key-download key-download)) + ((loc) + (or (package-field-location package 'version) + (package-location package)))) + (when version + (if (and=> tarball file-exists?) + (begin + (format (current-error-port) + (_ "~a: ~a: updating from version ~a to version ~a...~%") + (location->string loc) + (package-name package) + (package-version package) version) + (let ((hash (call-with-input-file tarball + port-sha256))) + (update-package-source package version hash))) + (warning (_ "~a: version ~a could not be \ downloaded and authenticated; not updating~%") - (package-name package) version))))) + (package-name package) version)))) + (when warn? + (warn-no-updater package)))) + +(define* (check-for-package-update package #:key warn?) + "Check whether an update is available for PACKAGE and print a message. When +WARN? is true and no updater exists for PACKAGE, print a warning." + (match (package-latest-release package %updaters) + ((? upstream-source? source) + (when (version>? (upstream-source-version source) + (package-version package)) + (let ((loc (or (package-field-location package 'version) + (package-location package)))) + (format (current-error-port) + (_ "~a: ~a would be upgraded from ~a to ~a~%") + (location->string loc) + (package-name package) (package-version package) + (upstream-source-version source))))) + (#f + (when warn? + (warn-no-updater package))))) + ;;; @@ -312,7 +341,7 @@ (define (options->updaters opts) ;; Return the list of updaters to use. (match (filter-map (match-lambda (('updaters . names) - (map lookup-updater names)) + (map lookup-updater-by-name names)) (_ #f)) opts) (() @@ -360,6 +389,12 @@ (define core-package? (updaters (options->updaters opts)) (list-dependent? (assoc-ref opts 'list-dependent?)) (key-download (assoc-ref opts 'key-download)) + + ;; Warn about missing updaters when a package is explicitly given on + ;; the command line. + (warn? (or (assoc-ref opts 'argument) + (assoc-ref opts 'expression))) + (packages (match (filter-map (match-lambda (('argument . spec) @@ -397,22 +432,13 @@ (define core-package? (%gpg-command)))) (for-each (cut update-package store <> updaters - #:key-download key-download) + #:key-download key-download + #:warn? warn?) packages) (with-monad %store-monad (return #t)))) (else - (for-each (lambda (package) - (match (package-update-path package updaters) - ((? upstream-source? source) - (let ((loc (or (package-field-location package 'version) - (package-location package)))) - (format (current-error-port) - (_ "~a: ~a would be upgraded from ~a to ~a~%") - (location->string loc) - (package-name package) (package-version package) - (upstream-source-version source)))) - (#f #f))) + (for-each (cut check-for-package-update <> #:warn? warn?) packages) (with-monad %store-monad (return #t))))))))) diff --git a/guix/upstream.scm b/guix/upstream.scm index 18157376d2..08992dc19e 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -49,8 +49,11 @@ (define-module (guix upstream) upstream-updater-predicate upstream-updater-latest + lookup-updater + download-tarball - package-update-path + package-latest-release + package-latest-release* package-update update-package-source)) @@ -127,17 +130,24 @@ (define (lookup-updater package updaters) (and (pred package) latest))) updaters)) -(define (package-update-path package updaters) +(define (package-latest-release package updaters) "Return an upstream source to update PACKAGE, a object, or #f if -no update is needed or known." +none of UPDATERS matches PACKAGE. It is the caller's responsibility to ensure +that the returned source is newer than the current one." (match (lookup-updater package updaters) ((? procedure? latest-release) - (match (latest-release package) - ((and source ($ name version)) - (and (version>? version (package-version package)) - source)) - (_ #f))) - (#f #f))) + (latest-release package)) + (_ #f))) + +(define (package-latest-release* package updaters) + "Like 'package-latest-release', but ensure that the return source is newer +than that of PACKAGE." + (match (package-latest-release package updaters) + ((and source ($ name version)) + (and (version>? version (package-version package)) + source)) + (_ + #f))) (define* (download-tarball store url signature-url #:key (key-download 'interactive)) @@ -179,7 +189,7 @@ (define* (package-update store package updaters PACKAGE, or #f and #f when PACKAGE is up-to-date. KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed values: 'always', 'never', and 'interactive' (default)." - (match (package-update-path package updaters) + (match (package-latest-release* package updaters) (($ _ version urls signature-urls) (let*-values (((name) (package-name package)) -- cgit v1.2.3 From 3e95d88d51a63854d44cbf8c8caa47b26d81e091 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 29 Nov 2016 16:10:10 +0100 Subject: gnu-maintenance: 'latest-kde-release' honors 'upstream-name' properties. * guix/gnu-maintenance.scm (latest-kde-release): Honor the 'upstream-name' property of PACKAGE. --- guix/gnu-maintenance.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 78392c9a11..6c6c0722d5 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -525,7 +525,8 @@ (define (latest-kde-release package) (let ((uri (string->uri (origin-uri (package-source package))))) (false-if-ftp-error (latest-ftp-release - (package-name package) + (or (assoc-ref (package-properties package) 'upstream-name) + (package-name package)) #:server "mirrors.mit.edu" #:directory (string-append "/kde" (dirname (dirname (uri-path uri)))) -- cgit v1.2.3 From 7632f7bc214b798ff3e154c2fac9a856aa9494e3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 30 Nov 2016 15:56:55 +0100 Subject: gnu-maintenance: Factorize URL prefix predicates. * guix/gnu-maintenance.scm (url-prefix-predicate): New procedure. (gnome-package?): Rewrite in terms of 'url-prefix-predicate'. (kde-package?, xorg-package?): Remove. (%kde-updater, %xorg-updater): Use 'url-prefix-predicate'. --- guix/gnu-maintenance.scm | 70 +++++++++++++++--------------------------------- 1 file changed, 22 insertions(+), 48 deletions(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 6c6c0722d5..90ca7a45e3 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -448,21 +448,26 @@ (define (pure-gnu-package? package) (not (gnome-package? package)) (gnu-package? package))) -(define (gnome-package? package) - "Return true if PACKAGE is a GNOME package, hosted on gnome.org." - (define gnome-uri? - (match-lambda - ((? string? uri) - (string-prefix? "mirror://gnome/" uri)) - (_ - #f))) - - (match (package-source package) - ((? origin? origin) - (match (origin-uri origin) - ((? gnome-uri?) #t) - (_ #f))) - (_ #f))) +(define (url-prefix-predicate prefix) + "Return a predicate that returns true when passed a package where one of its +source URLs starts with PREFIX." + (lambda (package) + (define matching-uri? + (match-lambda + ((? string? uri) + (string-prefix? prefix uri)) + (_ + #f))) + + (match (package-source package) + ((? origin? origin) + (match (origin-uri origin) + ((? matching-uri?) #t) + (_ #f))) + (_ #f)))) + +(define gnome-package? + (url-prefix-predicate "mirror://gnome/")) (define (latest-gnome-release package) "Return the latest release of PACKAGE, the name of a GNOME package." @@ -504,21 +509,6 @@ (define upstream-name ;; checksums. #:file->signature (const #f)))) -(define (kde-package? package) - "Return true if PACKAGE is a KDE package, developed by KDE.org." - (define kde-uri? - (match-lambda - ((? string? uri) - (string-prefix? "mirror://kde/" uri)) - (_ - #f))) - - (match (package-source package) - ((? origin? origin) - (match (origin-uri origin) - ((? kde-uri?) #t) - (_ #f))) - (_ #f))) (define (latest-kde-release package) "Return the latest release of PACKAGE, the name of an KDE.org package." @@ -532,22 +522,6 @@ (define (latest-kde-release package) (string-append "/kde" (dirname (dirname (uri-path uri)))) #:file->signature (const #f))))) -(define (xorg-package? package) - "Return true if PACKAGE is an X.org package, developed by X.org." - (define xorg-uri? - (match-lambda - ((? string? uri) - (string-prefix? "mirror://xorg/" uri)) - (_ - #f))) - - (match (package-source package) - ((? origin? origin) - (match (origin-uri origin) - ((? xorg-uri?) #t) - (_ #f))) - (_ #f))) - (define (latest-xorg-release package) "Return the latest release of PACKAGE, the name of an X.org package." (let ((uri (string->uri (origin-uri (package-source package))))) @@ -576,14 +550,14 @@ (define %kde-updater (upstream-updater (name 'kde) (description "Updater for KDE packages") - (pred kde-package?) + (pred (url-prefix-predicate "mirror://kde/")) (latest latest-kde-release))) (define %xorg-updater (upstream-updater (name 'xorg) (description "Updater for X.org packages") - (pred xorg-package?) + (pred (url-prefix-predicate "mirror://xorg/")) (latest latest-xorg-release))) ;;; gnu-maintenance.scm ends here -- cgit v1.2.3 From 4e6230ec00de1090e2780130f7de3a799c626e9b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 30 Nov 2016 16:26:08 +0100 Subject: refresh: Honor the selected updaters when '-u' isn't given. Fixes a regression introduced in e9c72306fdfd6a60158918850cb25d0ff3837d16. * guix/scripts/refresh.scm (check-for-package-update): Add 'updaters' parameter and honor it. (guix-refresh): Pass UPDATERS to 'check-for-package-update'. --- guix/scripts/refresh.scm | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index ed28ed5fcb..91a31a280b 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -261,10 +261,10 @@ (define* (update-package store package updaters (when warn? (warn-no-updater package)))) -(define* (check-for-package-update package #:key warn?) +(define* (check-for-package-update package updaters #:key warn?) "Check whether an update is available for PACKAGE and print a message. When WARN? is true and no updater exists for PACKAGE, print a warning." - (match (package-latest-release package %updaters) + (match (package-latest-release package updaters) ((? upstream-source? source) (when (version>? (upstream-source-version source) (package-version package)) @@ -438,7 +438,8 @@ (define core-package? (with-monad %store-monad (return #t)))) (else - (for-each (cut check-for-package-update <> #:warn? warn?) + (for-each (cut check-for-package-update <> updaters + #:warn? warn?) packages) (with-monad %store-monad (return #t))))))))) -- cgit v1.2.3 From 8d5d06282e255557d3bdda1794bd3fea2c84ff59 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 30 Nov 2016 17:30:12 +0100 Subject: upstream: Properly verify signatures of uncompressed tarballs. * guix/upstream.scm (uncompressed-tarball): New procedure. (download-tarball): Use it when the basename of SIGNATURE-URL doesn't contain the basename of URL. --- guix/upstream.scm | 49 +++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 47 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/upstream.scm b/guix/upstream.scm index 08992dc19e..8685afd860 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -26,6 +26,11 @@ (define-module (guix upstream) #:use-module (guix packages) #:use-module (guix ui) #:use-module (guix base32) + #:use-module (guix gexp) + #:use-module (guix store) + #:use-module ((guix derivations) + #:select (built-derivations derivation->output-path)) + #:use-module (guix monads) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) @@ -149,6 +154,32 @@ (define (package-latest-release* package updaters) (_ #f))) +(define (uncompressed-tarball name tarball) + "Return a derivation that decompresses TARBALL." + (define (ref package) + (module-ref (resolve-interface '(gnu packages compression)) + package)) + + (define compressor + (cond ((or (string-suffix? ".gz" tarball) + (string-suffix? ".tgz" tarball)) + (file-append (ref 'gzip) "/bin/gzip")) + ((string-suffix? ".bz2" tarball) + (file-append (ref 'bzip2) "/bin/bzip2")) + ((string-suffix? ".xz" tarball) + (file-append (ref 'xz) "/bin/xz")) + ((string-suffix? ".lz" tarball) + (file-append (ref 'lzip) "/bin/lzip")) + (else + (error "unknown archive type" tarball)))) + + (gexp->derivation (file-sans-extension name) + #~(begin + (copy-file #+tarball #+name) + (and (zero? (system* #+compressor "-d" #+name)) + (copy-file #+(file-sans-extension name) + #$output))))) + (define* (download-tarball store url signature-url #:key (key-download 'interactive)) "Download the tarball at URL to the store; check its OpenPGP signature at @@ -159,8 +190,22 @@ (define* (download-tarball store url signature-url (let ((tarball (download-to-store store url))) (if (not signature-url) tarball - (let* ((sig (download-to-store store signature-url)) - (ret (gnupg-verify* sig tarball #:key-download key-download))) + (let* ((sig (download-to-store store signature-url)) + + ;; Sometimes we get a signature over the uncompressed tarball. + ;; In that case, decompress the tarball in the store so that we + ;; can check the signature. + (data (if (string-prefix? (basename url) + (basename signature-url)) + tarball + (run-with-store store + (mlet %store-monad ((drv (uncompressed-tarball + (basename url) tarball))) + (mbegin %store-monad + (built-derivations (list drv)) + (return (derivation->output-path drv))))))) + + (ret (gnupg-verify* sig data #:key-download key-download))) (if ret tarball (begin -- cgit v1.2.3 From 2fd370e8167be9a0af9e5358757d58d1acaf02e0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 30 Nov 2016 16:29:15 +0100 Subject: gnu-maintenance: Add kernel.org updater. * guix/gnu-maintenance.scm (latest-kernel.org-release): New procedure. (%kernel.org-updater): New variable. * guix/scripts/refresh.scm (%updaters): Add it. --- doc/guix.texi | 2 ++ guix/gnu-maintenance.scm | 26 +++++++++++++++++++++++++- guix/scripts/refresh.scm | 4 +++- 3 files changed, 30 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 53d29e45be..37bdb69b56 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5342,6 +5342,8 @@ the updater for GNOME packages; the updater for KDE packages; @item xorg the updater for X.org packages; +@item kernel.org +the updater for packages hosted on kernel.org; @item elpa the updater for @uref{http://elpa.gnu.org/, ELPA} packages; @item cran diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 90ca7a45e3..4d4bb452be 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -60,7 +60,8 @@ (define-module (guix gnu-maintenance) %gnu-updater %gnome-updater %kde-updater - %xorg-updater)) + %xorg-updater + %kernel.org-updater)) ;;; Commentary: ;;; @@ -532,6 +533,22 @@ (define (latest-xorg-release package) #:directory (string-append "/pub/xorg/" (dirname (uri-path uri))))))) +(define (latest-kernel.org-release package) + "Return the latest release of PACKAGE, the name of a kernel.org package." + (let ((uri (string->uri (origin-uri (package-source package))))) + (false-if-ftp-error + (latest-ftp-release + (package-name package) + #:server "ftp.free.fr" ;a mirror reachable over FTP + #:directory (string-append "/mirrors/ftp.kernel.org" + (dirname (uri-path uri))) + + ;; kernel.org provides "foo-x.y.tar.sign" files, which are signatures of + ;; the uncompressed tarball. + #:file->signature (lambda (tarball) + (string-append (file-sans-extension tarball) + ".sign")))))) + (define %gnu-updater (upstream-updater (name 'gnu) @@ -560,4 +577,11 @@ (define %xorg-updater (pred (url-prefix-predicate "mirror://xorg/")) (latest latest-xorg-release))) +(define %kernel.org-updater + (upstream-updater + (name 'kernel.org) + (description "Updater for packages hosted on kernel.org") + (pred (url-prefix-predicate "mirror://kernel.org/")) + (latest latest-kernel.org-release))) + ;;; gnu-maintenance.scm ends here diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 91a31a280b..12a344e1a0 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -35,7 +35,8 @@ (define-module (guix scripts refresh) #:select (%gnu-updater %gnome-updater %kde-updater - %xorg-updater)) + %xorg-updater + %kernel.org-updater)) #:use-module (guix import elpa) #:use-module (guix import cran) #:use-module (guix import hackage) @@ -200,6 +201,7 @@ (define %updaters %gnome-updater %kde-updater %xorg-updater + %kernel.org-updater %elpa-updater %cran-updater %bioconductor-updater -- cgit v1.2.3 From 3676f892551d562e1a1360d79b208e687ece08c2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 30 Nov 2016 16:45:19 +0100 Subject: refresh: '--list-updaters' shows updater coverage. * guix/scripts/refresh.scm (list-updaters-and-exit): Compute the coverage ratio of each updater and print it. Print the coverage ratio for all the updaters. * doc/guix.texi (Invoking guix refresh): Document it. --- doc/guix.texi | 3 +++ guix/scripts/refresh.scm | 27 ++++++++++++++++++++++----- 2 files changed, 25 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 37bdb69b56..3b4ba487ad 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5394,6 +5394,9 @@ be used when passing @command{guix refresh} one or more package names: @itemx -L List available updaters and exit (see @option{--type} above.) +For each updater, display the fraction of packages it covers; at the +end, display the fraction of packages covered by all these updaters. + @item --list-dependent @itemx -l List top-level dependent packages that would need to be rebuilt as a diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 12a344e1a0..e1ff544de0 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -220,11 +220,28 @@ (define (lookup-updater-by-name name) (define (list-updaters-and-exit) "Display available updaters and exit." (format #t (_ "Available updaters:~%")) - (for-each (lambda (updater) - (format #t "- ~a: ~a~%" - (upstream-updater-name updater) - (_ (upstream-updater-description updater)))) - %updaters) + (newline) + + (let* ((packages (fold-packages cons '())) + (total (length packages))) + (define covered + (fold (lambda (updater covered) + (let ((matches (count (upstream-updater-predicate updater) + packages))) + ;; TRANSLATORS: The parenthetical expression here is rendered + ;; like "(42% coverage)" and denotes the fraction of packages + ;; covered by the given updater. + (format #t (_ " - ~a: ~a (~2,1f% coverage)~%") + (upstream-updater-name updater) + (_ (upstream-updater-description updater)) + (* 100. (/ matches total))) + (+ covered matches))) + 0 + %updaters)) + + (newline) + (format #t (_ "~2,1f% of the packages are covered by these updaters.~%") + (* 100. (/ covered total)))) (exit 0)) (define (warn-no-updater package) -- cgit v1.2.3