From 9daf046c5dd9256e45073dfd4647e12de10dcb3e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 14 Sep 2018 17:30:06 +0200 Subject: inferior: Add 'inferior-package-derivation'. * guix/inferior.scm (read-inferior-response) (send-inferior-request): New procedures. (inferior-eval): Rewrite in terms of these. (proxy, inferior-package-derivation, inferior-package->derivation) (package-compiler): New procedures. * tests/inferior.scm ("inferior-package-derivation"): New test. --- tests/inferior.scm | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) (limited to 'tests') diff --git a/tests/inferior.scm b/tests/inferior.scm index ff5cad4210..817fcb6c6b 100644 --- a/tests/inferior.scm +++ b/tests/inferior.scm @@ -17,9 +17,13 @@ ;;; along with GNU Guix. If not, see . (define-module (test-inferior) + #:use-module (guix tests) #:use-module (guix inferior) #:use-module (guix packages) + #:use-module (guix store) + #:use-module (guix derivations) #:use-module (gnu packages) + #:use-module (gnu packages bootstrap) #:use-module (srfi srfi-1) #:use-module (srfi srfi-64)) @@ -29,6 +33,9 @@ (define %top-builddir (dirname (search-path %load-compiled-path "guix.go"))) +(define %store + (open-connection-for-tests)) + (test-begin "inferior") @@ -72,4 +79,19 @@ (close-inferior inferior) result)))) +(test-equal "inferior-package-derivation" + (map derivation-file-name + (list (package-derivation %store %bootstrap-guile "x86_64-linux") + (package-derivation %store %bootstrap-guile "armhf-linux"))) + (let* ((inferior (open-inferior %top-builddir + #:command "scripts/guix")) + (packages (inferior-packages inferior)) + (guile (find (lambda (package) + (string=? (package-name %bootstrap-guile) + (inferior-package-name package))) + packages))) + (map derivation-file-name + (list (inferior-package-derivation %store guile "x86_64-linux") + (inferior-package-derivation %store guile "armhf-linux"))))) + (test-end "inferior") -- cgit v1.2.3 From e1a4ffdab52f616f41de4ff783a712bcd50a5187 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sat, 15 Sep 2018 14:50:14 +0200 Subject: inferior: Add 'lookup-inferior-packages'. * guix/inferior.scm ()[packages, table]: New fields. (open-inferior): Initialize these new fields. (inferior-packages): Rename to... (%inferior-packages): ... this. (inferior-packages): New procedure; force the promise. (%inferior-package-table, lookup-inferior-packages): New procedures. * tests/inferior.scm ("lookup-inferior-packages") ("lookup-inferior-packages and eq?-ness"): New tests. --- tests/inferior.scm | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) (limited to 'tests') diff --git a/tests/inferior.scm b/tests/inferior.scm index 817fcb6c6b..791e30b179 100644 --- a/tests/inferior.scm +++ b/tests/inferior.scm @@ -79,6 +79,35 @@ (close-inferior inferior) result)))) +(test-equal "lookup-inferior-packages" + (let ((->list (lambda (package) + (list (package-name package) + (package-version package) + (package-location package))))) + (list (map ->list (find-packages-by-name "guile" #f)) + (map ->list (find-packages-by-name "guile" "2.2")))) + (let* ((inferior (open-inferior %top-builddir + #:command "scripts/guix")) + (->list (lambda (package) + (list (inferior-package-name package) + (inferior-package-version package) + (inferior-package-location package)))) + (lst1 (map ->list + (lookup-inferior-packages inferior "guile"))) + (lst2 (map ->list + (lookup-inferior-packages inferior + "guile" "2.2")))) + (close-inferior inferior) + (list lst1 lst2))) + +(test-assert "lookup-inferior-packages and eq?-ness" + (let* ((inferior (open-inferior %top-builddir + #:command "scripts/guix")) + (lst1 (lookup-inferior-packages inferior "guile")) + (lst2 (lookup-inferior-packages inferior "guile"))) + (close-inferior inferior) + (every eq? lst1 lst2))) + (test-equal "inferior-package-derivation" (map derivation-file-name (list (package-derivation %store %bootstrap-guile "x86_64-linux") -- cgit v1.2.3 From 6030396aec325b3c3287a472014bc2d530abb99d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 17 Sep 2018 09:55:31 +0200 Subject: inferior: Add 'inferior-package-inputs' & co. * guix/inferior.scm (open-inferior): Use (ice-9 match). (inferior-package-input-field, inferior-package-inputs): (inferior-package-native-inputs) (inferior-package-propagated-inputs) (inferior-package-transitive-propagated-inputs): New procedures. * tests/inferior.scm ("inferior-package-inputs"): New test. inputs fixlet --- tests/inferior.scm | 34 +++++++++++++++++++++++++++++++++- 1 file changed, 33 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/tests/inferior.scm b/tests/inferior.scm index 791e30b179..03170a19c9 100644 --- a/tests/inferior.scm +++ b/tests/inferior.scm @@ -24,8 +24,10 @@ #:use-module (guix derivations) #:use-module (gnu packages) #:use-module (gnu packages bootstrap) + #:use-module (gnu packages guile) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-64)) + #:use-module (srfi srfi-64) + #:use-module (ice-9 match)) (define %top-srcdir (dirname (search-path %load-path "guix.scm"))) @@ -108,6 +110,36 @@ (close-inferior inferior) (every eq? lst1 lst2))) +(test-equal "inferior-package-inputs" + (let ((->list (match-lambda + ((label (? package? package) . rest) + `(,label + (package ,(package-name package) + ,(package-version package) + ,(package-location package)) + ,@rest))))) + (list (map ->list (package-inputs guile-2.2)) + (map ->list (package-native-inputs guile-2.2)) + (map ->list (package-propagated-inputs guile-2.2)))) + (let* ((inferior (open-inferior %top-builddir + #:command "scripts/guix")) + (guile (first (lookup-inferior-packages inferior "guile"))) + (->list (match-lambda + ((label (? inferior-package? package) . rest) + `(,label + (package ,(inferior-package-name package) + ,(inferior-package-version package) + ,(inferior-package-location package)) + ,@rest)))) + (result (list (map ->list (inferior-package-inputs guile)) + (map ->list + (inferior-package-native-inputs guile)) + (map ->list + (inferior-package-propagated-inputs + guile))))) + (close-inferior inferior) + result)) + (test-equal "inferior-package-derivation" (map derivation-file-name (list (package-derivation %store %bootstrap-guile "x86_64-linux") -- cgit v1.2.3 From eee8b303f6d82c1400fd8fd3b097406358ed7875 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 17 Sep 2018 10:04:15 +0200 Subject: inferior: Add 'inferior-package-search-paths' & co. * guix/inferior.scm (%inferior-package-search-paths) (inferior-package-native-search-paths) (inferior-package-search-paths) (inferior-package-transitive-native-search-paths): New procedures. * tests/inferior.scm ("inferior-package-search-paths"): New test. --- tests/inferior.scm | 9 +++++++++ 1 file changed, 9 insertions(+) (limited to 'tests') diff --git a/tests/inferior.scm b/tests/inferior.scm index 03170a19c9..99d736bd40 100644 --- a/tests/inferior.scm +++ b/tests/inferior.scm @@ -140,6 +140,15 @@ (close-inferior inferior) result)) +(test-equal "inferior-package-search-paths" + (package-native-search-paths guile-2.2) + (let* ((inferior (open-inferior %top-builddir + #:command "scripts/guix")) + (guile (first (lookup-inferior-packages inferior "guile"))) + (result (inferior-package-native-search-paths guile))) + (close-inferior inferior) + result)) + (test-equal "inferior-package-derivation" (map derivation-file-name (list (package-derivation %store %bootstrap-guile "x86_64-linux") -- cgit v1.2.3 From 2e6d64e122ad2745154a38122785895d1b66c2ff Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 18 Sep 2018 09:56:34 +0200 Subject: inferior: Add 'inferior-package->manifest-entry'. * guix/inferior.scm (inferior-package->manifest-entry): New procedure. * tests/inferior.scm (manifest-entry->list): New procedure. ("inferior-package->manifest-entry"): New test. --- tests/inferior.scm | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) (limited to 'tests') diff --git a/tests/inferior.scm b/tests/inferior.scm index 99d736bd40..6f6abd28a1 100644 --- a/tests/inferior.scm +++ b/tests/inferior.scm @@ -21,6 +21,7 @@ #:use-module (guix inferior) #:use-module (guix packages) #:use-module (guix store) + #:use-module (guix profiles) #:use-module (guix derivations) #:use-module (gnu packages) #:use-module (gnu packages bootstrap) @@ -38,6 +39,13 @@ (define %store (open-connection-for-tests)) +(define (manifest-entry->list entry) + (list (manifest-entry-name entry) + (manifest-entry-version entry) + (manifest-entry-output entry) + (manifest-entry-search-paths entry) + (map manifest-entry->list (manifest-entry-dependencies entry)))) + (test-begin "inferior") @@ -164,4 +172,14 @@ (list (inferior-package-derivation %store guile "x86_64-linux") (inferior-package-derivation %store guile "armhf-linux"))))) +(test-equal "inferior-package->manifest-entry" + (manifest-entry->list (package->manifest-entry + (first (find-best-packages-by-name "guile" #f)))) + (let* ((inferior (open-inferior %top-builddir + #:command "scripts/guix")) + (guile (first (lookup-inferior-packages inferior "guile"))) + (entry (inferior-package->manifest-entry guile))) + (close-inferior inferior) + (manifest-entry->list entry))) + (test-end "inferior") -- cgit v1.2.3 From 811b21fb15d36b06fde994ca7ef5916a9a19f250 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 18 Sep 2018 10:21:28 +0200 Subject: profiles: 'packages->manifest' now accepts inferior packages. * guix/profiles.scm (packages->manifest)[inferiors-loaded?]: New variable. [inferior->entry]: New procedure. Accept inferior packages when INFERIORS-LOADED? is true. * tests/guix-package.sh: Add test using a manifest with an inferior. * tests/inferior.scm ("packages->manifest"): New test. --- tests/guix-package.sh | 15 +++++++++++++++ tests/inferior.scm | 11 +++++++++++ 2 files changed, 26 insertions(+) (limited to 'tests') diff --git a/tests/guix-package.sh b/tests/guix-package.sh index cef3b3452e..f7dfbfad00 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -358,6 +358,21 @@ EOF guix package --bootstrap -m "$module_dir/manifest.scm" guix package -I | grep guile test `guix package -I | wc -l` -eq 1 +guix package --rollback --bootstrap + +# Applying a manifest file with inferior packages. +cat > "$module_dir/manifest.scm"<manifest (list guile))) +EOF +guix package --bootstrap -m "$module_dir/manifest.scm" +guix package -I | grep guile +test `guix package -I | wc -l` -eq 1 # Error reporting. cat > "$module_dir/manifest.scm"<list entry))) +(test-equal "packages->manifest" + (map manifest-entry->list + (manifest-entries (packages->manifest + (find-best-packages-by-name "guile" #f)))) + (let* ((inferior (open-inferior %top-builddir + #:command "scripts/guix")) + (guile (first (lookup-inferior-packages inferior "guile"))) + (manifest (packages->manifest (list guile)))) + (close-inferior inferior) + (map manifest-entry->list (manifest-entries manifest)))) + (test-end "inferior") -- cgit v1.2.3 From dc0f74e5fc26977a3ee6c4f2aa74a141f4359982 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 18 Jan 2017 23:21:29 +0100 Subject: Add (guix status) and use it for pretty colored output. * guix/progress.scm (progress-reporter/trace): New procedure. (%progress-interval): New variable. (progress-reporter/file): Use it. * guix/scripts/build.scm (set-build-options-from-command-line): Pass #:print-extended-build-trace?. (%default-options): Add 'print-extended-build-trace?'. (guix-build): Parameterize CURRENT-TERMINAL-COLUMNS. Use 'build-status-updater'. * guix/scripts/environment.scm (%default-options): Add 'print-extended-build-trace?'. (guix-environment): Wrap body in 'with-status-report'. * guix/scripts/pack.scm (%default-options): Add 'print-build-trace?' and 'print-extended-build-trace?'. (guix-pack): Wrap body in 'with-status-report'. * guix/scripts/package.scm (%default-options, guix-package): Likewise. * guix/scripts/system.scm (%default-options, guix-system): Likewise. * guix/scripts/pull.scm (%default-options, guix-pull): Likewise. * guix/scripts/substitute.scm (progress-report-port): Don't call STOP when TOTAL is zero. (process-substitution): Add #:print-build-trace? and honor it. (guix-substitute)[print-build-trace?]: New variable. Pass #:print-build-trace? to 'process-substitution'. * guix/status.scm: New file. * guix/store.scm (set-build-options): Add #:print-extended-build-trace?; pass it into PAIRS. (%protocol-version): Bump. (protocol-version, nix-server-version): New procedures. (current-store-protocol-version): New variable. (with-store, build-things): Parameterize it. * guix/ui.scm (build-output-port): Remove. (colorize-string): Export. * po/guix/POTFILES.in: Add guix/status.scm. * tests/status.scm: New file. * Makefile.am (SCM_TESTS): Add it. * nix/libstore/worker-protocol.hh (PROTOCOL_VERSION): Bump to 0x162. * nix/libstore/build.cc (DerivationGoal::registerOutputs) (SubstitutionGoal::finished): Print a "@ hash-mismatch" trace before throwing. --- tests/status.scm | 115 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 115 insertions(+) create mode 100644 tests/status.scm (limited to 'tests') diff --git a/tests/status.scm b/tests/status.scm new file mode 100644 index 0000000000..04dedb702c --- /dev/null +++ b/tests/status.scm @@ -0,0 +1,115 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (test-status) + #:use-module (guix status) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-64)) + +(test-begin "status") + +(test-equal "compute-status, no-op" + (build-status) + (let-values (((port get-status) + (build-event-output-port compute-status))) + (display "foo\nbar\n\baz\n" port) + (get-status))) + +(test-equal "compute-status, builds + substitutes" + (list (build-status + (building '("foo.drv")) + (downloading (list (download "bar" "http://example.org/bar" + #:size 500 + #:start 'now)))) + (build-status + (building '("foo.drv")) + (downloading (list (download "bar" "http://example.org/bar" + #:size 500 + #:transferred 42 + #:start 'now)))) + (build-status + (builds-completed '("foo.drv")) + (downloads-completed (list (download "bar" "http://example.org/bar" + #:size 500 + #:transferred 500 + #:start 'now + #:end 'now))))) + (let-values (((port get-status) + (build-event-output-port (lambda (event status) + (compute-status event status + #:current-time + (const 'now)))))) + (display "@ build-started foo.drv\n" port) + (display "@ substituter-started bar\n" port) + (display "@ download-started bar http://example.org/bar 500\n" port) + (display "various\nthings\nget\nwritten\n" port) + (let ((first (get-status))) + (display "@ download-progress bar http://example.org/bar 500 42\n" + port) + (let ((second (get-status))) + (display "@ download-progress bar http://example.org/bar 500 84\n" + port) + (display "@ build-succeeded foo.drv\n" port) + (display "@ download-succeeded bar http://example.org/bar 500\n" port) + (display "Almost done!\n" port) + (display "@ substituter-succeeded bar\n" port) + (list first second (get-status)))))) + +(test-equal "compute-status, missing events" + (list (build-status + (building '("foo.drv")) + (downloading (list (download "baz" "http://example.org/baz" + #:size 500 + #:transferred 42 + #:start 'now) + (download "bar" "http://example.org/bar" + #:size 999 + #:transferred 0 + #:start 'now)))) + (build-status + (builds-completed '("foo.drv")) + (downloads-completed (list (download "baz" "http://example.org/baz" + #:size 500 + #:transferred 500 + #:start 'now + #:end 'now) + (download "bar" "http://example.org/bar" + #:size 999 + #:transferred 999 + #:start 'now + #:end 'now))))) + ;; Below we omit 'substituter-started' events and the like. + (let-values (((port get-status) + (build-event-output-port (lambda (event status) + (compute-status event status + #:current-time + (const 'now)))))) + (display "@ build-started foo.drv\n" port) + (display "@ download-started bar http://example.org/bar 999\n" port) + (display "various\nthings\nget\nwritten\n" port) + (display "@ download-progress baz http://example.org/baz 500 42\n" + port) + (let ((first (get-status))) + (display "@ build-succeeded foo.drv\n" port) + (display "@ download-succeeded bar http://example.org/bar 999\n" port) + (display "Almost done!\n" port) + (display "@ substituter-succeeded baz\n" port) + (list first (get-status))))) + +(test-end "status") -- cgit v1.2.3 From d4e9317b9de29f77eb8559bd99e0e2fe20d5f1fe Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 27 Sep 2018 23:46:44 +0200 Subject: tests: Update (guix build store-copy) tests. This is a followup to a387b0bebb151a766ca6a454a891f2370c96703c. * tests/gexp.scm ("gexp->derivation, store copy") ("gexp->derivation #:references-graphs"): Add (guix progress) and (guix records) to the imported modules. --- tests/gexp.scm | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'tests') diff --git a/tests/gexp.scm b/tests/gexp.scm index 5d049cd5fc..813ea2ff6f 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -615,6 +615,8 @@ `(("graph" ,two)) #:modules '((guix build store-copy) + (guix progress) + (guix records) (guix sets) (guix build utils)))) (ok? (built-derivations (list drv))) @@ -817,6 +819,8 @@ (two (gexp->derivation "two" #~(symlink #$one #$output:chbouib))) (build -> (with-imported-modules '((guix build store-copy) + (guix progress) + (guix records) (guix sets) (guix build utils)) #~(begin -- cgit v1.2.3 From 7fed9353ece5974ff431fa666a530da237a12085 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 27 Sep 2018 23:58:05 +0200 Subject: tests: Adjust services tests to new 'shepherd-service-upgrade'. This is a followup to 4245ddcbc9f935804c17c97872b90ec1050c2d75. * tests/services.scm ("shepherd-service-upgrade: one unchanged, one upgraded, one new") ("shepherd-service-upgrade: service depended on is not unloaded") ("shepherd-service-upgrade: obsolete services that depend on each other"): Adjust to changes in 'shepherd-service-upgrade'. --- tests/services.scm | 30 ++++++++++++++++-------------- 1 file changed, 16 insertions(+), 14 deletions(-) (limited to 'tests') diff --git a/tests/services.scm b/tests/services.scm index 1ad577e601..5827dee80d 100644 --- a/tests/services.scm +++ b/tests/services.scm @@ -207,13 +207,14 @@ list)) (test-equal "shepherd-service-upgrade: one unchanged, one upgraded, one new" - '(((bar)) ;unload - ((bar) (baz))) ;load + '(() ;unload + ((foo))) ;restart (call-with-values (lambda () - ;; Here 'foo' is not upgraded because it is still running, whereas - ;; 'bar' is upgraded because it is not currently running. 'baz' is - ;; loaded because it's a new service. + ;; Here 'foo' is replaced and must be explicitly restarted later + ;; because it is still running, whereas 'bar' is upgraded right away + ;; because it is not currently running. 'baz' is loaded because it's + ;; a new service. (shepherd-service-upgrade (list (live-service '(foo) '() #t) (live-service '(bar) '() #f) @@ -224,30 +225,31 @@ (start #t)) (shepherd-service (provision '(baz)) (start #t))))) - (lambda (unload load) + (lambda (unload restart) (list (map live-service-provision unload) - (map shepherd-service-provision load))))) + (map shepherd-service-provision restart))))) (test-equal "shepherd-service-upgrade: service depended on is not unloaded" '(((baz)) ;unload - ()) ;load + ((foo))) ;restart (call-with-values (lambda () ;; Service 'bar' is not among the target services; yet, it must not be - ;; unloaded because 'foo' depends on it. + ;; unloaded because 'foo' depends on it. 'foo' gets replaced but it + ;; must be restarted manually. (shepherd-service-upgrade (list (live-service '(foo) '(bar) #t) (live-service '(bar) '() #t) ;still used! (live-service '(baz) '() #t)) (list (shepherd-service (provision '(foo)) (start #t))))) - (lambda (unload load) + (lambda (unload restart) (list (map live-service-provision unload) - (map shepherd-service-provision load))))) + (map shepherd-service-provision restart))))) (test-equal "shepherd-service-upgrade: obsolete services that depend on each other" '(((foo) (bar) (baz)) ;unload - ((qux))) ;load + ()) ;restart (call-with-values (lambda () ;; 'foo', 'bar', and 'baz' depend on each other, but all of them are @@ -258,9 +260,9 @@ (live-service '(baz) '() #t)) ;obsolete (list (shepherd-service (provision '(qux)) (start #t))))) - (lambda (unload load) + (lambda (unload restart) (list (map live-service-provision unload) - (map shepherd-service-provision load))))) + (map shepherd-service-provision restart))))) (test-eq "lookup-service-types" system-service-type -- cgit v1.2.3 From fe17037b387c6eca0c45f0526d2761e982a192bb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 9 Oct 2018 09:53:02 +0200 Subject: status: Gracefully handle invalid UTF-8 in build logs. * guix/status.scm (maybe-utf8->string): New procedure. (build-event-output-port): Use it in lieu of 'utf8->string'. * tests/status.scm ("build-output-port, UTF-8") ("current-build-output-port, UTF-8 + garbage"): New tests. --- tests/status.scm | 22 +++++++++++++++++++++- 1 file changed, 21 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/tests/status.scm b/tests/status.scm index 04dedb702c..486ad04dd2 100644 --- a/tests/status.scm +++ b/tests/status.scm @@ -20,7 +20,9 @@ #:use-module (guix status) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) - #:use-module (srfi srfi-64)) + #:use-module (srfi srfi-64) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports)) (test-begin "status") @@ -112,4 +114,22 @@ (display "@ substituter-succeeded baz\n" port) (list first (get-status))))) +(test-equal "build-output-port, UTF-8" + '((build-log "lambda is λ!\n")) + (let-values (((port get-status) (build-event-output-port cons '())) + ((bv) (string->utf8 "lambda is λ!\n"))) + (put-bytevector port bv) + (force-output port) + (get-status))) + +(test-equal "current-build-output-port, UTF-8 + garbage" + ;; What about a mixture of UTF-8 + garbage? + '((build-log "garbage: �lambda: λ\n")) + (let-values (((port get-status) (build-event-output-port cons '()))) + (display "garbage: " port) + (put-bytevector port #vu8(128)) + (put-bytevector port (string->utf8 "lambda: λ\n")) + (force-output port) + (get-status))) + (test-end "status") -- cgit v1.2.3 From b33e191c86b7638517ea838b63a54d031a033554 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 9 Oct 2018 18:52:37 +0200 Subject: guix build: '-f' accepts file-like objects. * guix/scripts/build.scm (options->things-to-build)[validate-type]: Check for 'file-like?'. (options->derivations): Accept 'file-like?'. * tests/guix-build.sh: Add a test with 'computed-file'. * doc/guix.texi (Additional Build Options): Mention file-like objects. --- tests/guix-build.sh | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'tests') diff --git a/tests/guix-build.sh b/tests/guix-build.sh index 92e7299321..7842ce87c6 100644 --- a/tests/guix-build.sh +++ b/tests/guix-build.sh @@ -221,6 +221,10 @@ guix build -e "(begin guix build -e '#~(mkdir #$output)' -d guix build -e '#~(mkdir #$output)' -d | grep 'gexp\.drv' +# Same with a file-like object. +guix build -e '(computed-file "foo" #~(mkdir #$output))' -d +guix build -e '(computed-file "foo" #~(mkdir #$output))' -d | grep 'foo\.drv' + # Building from a package file. cat > "$module_dir/package.scm"< Date: Mon, 15 Oct 2018 22:40:35 +0200 Subject: daemon: Support multiplexed build output. This allows clients to tell whether output comes from the daemon or, if it comes from a builder, from which builder it comes. The latter is particularly useful when MAX-BUILD-JOBS > 1. * nix/libstore/build.cc (DerivationGoal::tryBuildHook) (DerivationGoal::startBuilder): Print the child's PID in "@ build-started" traces. (DerivationGoal::handleChildOutput): Define 'prefix', pass it to 'writeToStderr'. * nix/libstore/globals.cc (Settings:Settings): Initialize 'multiplexedBuildOutput'. (Settings::update): Likewise. * nix/libstore/globals.hh (Settings)[multiplexedBuildOutput]: New field. Update 'printBuildTrace' documentation. * nix/libstore/worker-protocol.hh (PROTOCOL_VERSION): Bump to 0.163. * nix/nix-daemon/nix-daemon.cc (performOp) : Special-case "multiplexed-build-output" and remove "use-ssh-substituter". * guix/store.scm (set-build-options): Add #:multiplexed-build-output? and honor it. (%protocol-version): Bump to #x163. * tests/store.scm ("multiplexed-build-output"): New test. fixlet --- tests/store.scm | 63 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 63 insertions(+) (limited to 'tests') diff --git a/tests/store.scm b/tests/store.scm index 2858369706..3ff526cdcf 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -31,6 +31,7 @@ #:use-module (gnu packages) #:use-module (gnu packages bootstrap) #:use-module (ice-9 match) + #:use-module (ice-9 regex) #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:use-module (web uri) @@ -1021,4 +1022,66 @@ (call-with-input-file (derivation->output-path drv2) read)))))) +(test-equal "multiplexed-build-output" + '("Hello from first." "Hello from second.") + (with-store store + (let* ((build (add-text-to-store store "build.sh" + "echo Hello from $NAME.; echo > $out")) + (bash (add-to-store store "bash" #t "sha256" + (search-bootstrap-binary "bash" + (%current-system)))) + (drv1 (derivation store "one" bash + `("-e" ,build) + #:inputs `((,bash) (,build)) + #:env-vars `(("NAME" . "first") + ("x" . ,(random-text))))) + (drv2 (derivation store "two" bash + `("-e" ,build) + #:inputs `((,bash) (,build)) + #:env-vars `(("NAME" . "second") + ("x" . ,(random-text)))))) + (set-build-options store + #:print-build-trace #t + #:multiplexed-build-output? #t + #:max-build-jobs 10) + (let ((port (open-output-string))) + ;; Send the build log to PORT. + (parameterize ((current-build-output-port port)) + (build-derivations store (list drv1 drv2))) + + ;; Retrieve the build log; make sure it contains valid "@ build-log" + ;; traces that allow us to retrieve each builder's output (we assume + ;; there's exactly one "build-output" trace for each builder, which is + ;; reasonable.) + (let* ((log (get-output-string port)) + (started (fold-matches + (make-regexp "@ build-started ([^ ]+) - ([^ ]+) ([^ ]+) ([0-9]+)") + log '() cons)) + (done (fold-matches + (make-regexp "@ build-succeeded (.*) - (.*) (.*) (.*)") + log '() cons)) + (output (fold-matches + (make-regexp "@ build-log ([[:digit:]]+) ([[:digit:]]+)\n([A-Za-z .*]+)\n") + log '() cons)) + (drv-pid (lambda (name) + (lambda (m) + (let ((drv (match:substring m 1)) + (pid (string->number + (match:substring m 4)))) + (and (string-suffix? name drv) pid))))) + (pid-log (lambda (pid) + (lambda (m) + (let ((n (string->number + (match:substring m 1))) + (len (string->number + (match:substring m 2))) + (str (match:substring m 3))) + (and (= pid n) + (= (string-length str) (- len 1)) + str))))) + (pid1 (any (drv-pid "one.drv") started)) + (pid2 (any (drv-pid "two.drv") started))) + (list (any (pid-log pid1) output) + (any (pid-log pid2) output))))))) + (test-end "store") -- cgit v1.2.3 From f9a8fce10f2d99efec7cb1dd0f6c5f0df9d1b2df Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 15 Oct 2018 23:06:55 +0200 Subject: status: Build upon multiplexed build output. This allows for more accurate status tracking and parsing of extended build traces. * guix/status.scm (multiplexed-output-supported?): New procedure. (print-build-event): Don't print \r when PRINT-LOG? is true. Adjust 'build-log' handling for when 'multiplexed-output-supported?' returns true. (bytevector-index, split-lines): New procedures. (build-event-output-port)[%build-output-pid, %build-output] [%build-output-left]: New variables. [process-line]: Handle "@ build-output" traces. [process-build-output]: New procedure. [write!]: Add case for when %BUILD-OUTPUT-PID is true. Use 'bytevector-index' rather than 'string-index'. (compute-status): Add #:derivation-path->output-path. Use it. * tests/status.scm ("compute-status, multiplexed build output"): New test. ("build-output-port, UTF-8") ("current-build-output-port, UTF-8 + garbage"): Adjust to new 'build-log' output. * guix/scripts/build.scm (set-build-options-from-command-line): Pass #:multiplexed-build-output?. (%default-options): Add 'multiplexed-build-output?'. * guix/scripts/environment.scm (%default-options): Likewise. * guix/scripts/pack.scm (%default-options): Likewise. * guix/scripts/package.scm (%default-options): Likewise. * guix/scripts/pull.scm (%default-options): Likewise. * guix/scripts/system.scm (%default-options): Likewise. --- tests/status.scm | 51 ++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 48 insertions(+), 3 deletions(-) (limited to 'tests') diff --git a/tests/status.scm b/tests/status.scm index 486ad04dd2..3b74946673 100644 --- a/tests/status.scm +++ b/tests/status.scm @@ -22,7 +22,8 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-64) #:use-module (rnrs bytevectors) - #:use-module (rnrs io ports)) + #:use-module (rnrs io ports) + #:use-module (ice-9 match)) (test-begin "status") @@ -115,7 +116,7 @@ (list first (get-status))))) (test-equal "build-output-port, UTF-8" - '((build-log "lambda is λ!\n")) + '((build-log #f "lambda is λ!\n")) (let-values (((port get-status) (build-event-output-port cons '())) ((bv) (string->utf8 "lambda is λ!\n"))) (put-bytevector port bv) @@ -124,7 +125,7 @@ (test-equal "current-build-output-port, UTF-8 + garbage" ;; What about a mixture of UTF-8 + garbage? - '((build-log "garbage: �lambda: λ\n")) + '((build-log #f "garbage: �lambda: λ\n")) (let-values (((port get-status) (build-event-output-port cons '()))) (display "garbage: " port) (put-bytevector port #vu8(128)) @@ -132,4 +133,48 @@ (force-output port) (get-status))) +(test-equal "compute-status, multiplexed build output" + (list (build-status + (building '("foo.drv")) + (downloading (list (download "bar" "http://example.org/bar" + #:size 999 + #:start 'now)))) + (build-status + (building '("foo.drv")) + (downloading (list (download "bar" "http://example.org/bar" + #:size 999 + #:transferred 42 + #:start 'now)))) + (build-status + ;; XXX: Should "bar.drv" be present twice? + (builds-completed '("bar.drv" "foo.drv")) + (downloads-completed (list (download "bar" "http://example.org/bar" + #:size 999 + #:transferred 999 + #:start 'now + #:end 'now))))) + (let-values (((port get-status) + (build-event-output-port (lambda (event status) + (compute-status event status + #:current-time + (const 'now) + #:derivation-path->output-path + (match-lambda + ("bar.drv" "bar"))))))) + (display "@ build-started foo.drv 121\n" port) + (display "@ build-started bar.drv 144\n" port) + (display "@ build-log 121 6\nHello!" port) + (display "@ build-log 144 50 +@ download-started bar http://example.org/bar 999\n" port) + (let ((first (get-status))) + (display "@ build-log 121 30\n@ build-started FAKE!.drv 555\n") + (display "@ build-log 144 54 +@ download-progress bar http://example.org/bar 999 42\n" + port) + (let ((second (get-status))) + (display "@ download-succeeded bar http://example.org/bar 999\n" port) + (display "@ build-succeeded foo.drv\n" port) + (display "@ build-succeeded bar.drv\n" port) + (list first second (get-status)))))) + (test-end "status") -- cgit v1.2.3 From 278f86a43f1561b1c064ce88da012db414ec7efc Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Wed, 10 Oct 2018 16:42:02 -0500 Subject: ui: Fix port-buffering with guile@2.0. * guix/status.scm (build-event-output-port)[guile@2.0]: Do not call 'setvbuf' on custom binary port. * tests/status.scm (current-build-output-port, UTF-8 + garbage)[guile@2.0]: Use "?" in place of REPLACEMENT CHARACTER. --- tests/status.scm | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/tests/status.scm b/tests/status.scm index 3b74946673..99abb41c8b 100644 --- a/tests/status.scm +++ b/tests/status.scm @@ -125,7 +125,10 @@ (test-equal "current-build-output-port, UTF-8 + garbage" ;; What about a mixture of UTF-8 + garbage? - '((build-log #f "garbage: �lambda: λ\n")) + (let ((replacement (cond-expand + ((and guile-2 (not guile-2.2)) "?") + (else "�")))) + `((build-log #f ,(string-append "garbage: " replacement "lambda: λ\n")))) (let-values (((port get-status) (build-event-output-port cons '()))) (display "garbage: " port) (put-bytevector port #vu8(128)) -- cgit v1.2.3 From 39d7fdce453b0ca23ecbed72048647debbaa58a6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 18 Oct 2018 00:45:05 +0200 Subject: services: dhcp-client: Deprecate 'dhcp-client-service' procedure. * gnu/services/networking.scm (dhcp-client-service-type): Add default value. * gnu/system/examples/bare-bones.tmpl: Use (service dhcp-client-service-type) instead of (dhcp-client-service). * gnu/system/examples/beaglebone-black.tmpl: Likewise. * gnu/tests/base.scm (%avahi-os): Likewise. * gnu/tests/databases.scm (%memcached-os): Likewise. (%mongodb-os): Likewise. * gnu/tests/dict.scm (%dicod-os): Likewise. * gnu/tests/mail.scm (%opensmtpd-os): Likewise. (%exim-os): Likewise. (%dovecot-os): Likewise. * gnu/tests/messaging.scm (run-xmpp-test): Likewise. (run-bitlbee-test): Likewise. * gnu/tests/monitoring.scm (%prometheus-node-exporter-os): Likewise. * gnu/tests/networking.scm (%inetd-os): Likewise. (run-iptables-test): Likewise. * gnu/tests/nfs.scm (%base-os): Likewise. * gnu/tests/rsync.scm (%rsync-os): Likewise. * gnu/tests/ssh.scm (run-ssh-test): Likewise. * gnu/tests/version-control.scm (%cgit-os): Likewise. (%git-http-os): Likewise. (%gitolite-os): Likewise. * gnu/tests/virtualization.scm (%libvirt-os): Likewise. * gnu/tests/web.scm (%httpd-os): Likewise. (%nginx-os): Likewise. (%varnish-os): Likewise. (%php-fpm-os): Likewise. (%hpcguix-web-os): Likewise. (%tailon-os): Likewise. * tests/guix-system.sh: Likewise. * doc/guix.texi (Networking Services): Document 'dhcp-client-service-type' and remove 'dhcp-client-service'. --- tests/guix-system.sh | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'tests') diff --git a/tests/guix-system.sh b/tests/guix-system.sh index a129efdfcb..23d2da4903 100644 --- a/tests/guix-system.sh +++ b/tests/guix-system.sh @@ -153,8 +153,8 @@ cat > "$tmpfile" < Date: Fri, 12 Oct 2018 23:47:15 -0400 Subject: gnu: Use pypi.org. redirects to . * guix/build-system/python.scm (pypi-uri): Replace pypi.io with pypi.org. * guix/import/pypi.scm (pypi-url?): Likewise. * tests/pypi.scm: Likewise. --- tests/pypi.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'tests') diff --git a/tests/pypi.scm b/tests/pypi.scm index 616ec191f5..6daa44a6e7 100644 --- a/tests/pypi.scm +++ b/tests/pypi.scm @@ -81,7 +81,7 @@ baz > 13.37") (dummy-package "foo" (source (dummy-origin (uri - "https://pypi.io/packages/source/p/psutil/psutil-4.3.0.tar.gz")))))) + "https://pypi.org/packages/source/p/psutil/psutil-4.3.0.tar.gz")))))) (test-equal "guix-package->pypi-name, new URL style" "certbot" -- cgit v1.2.3 From 19c924af4f3726688ca155a905ebf1cb9acdfca2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 19 Oct 2018 17:58:00 +0200 Subject: tests: Run 'guix pack' tests using the external store. Fixes . * guix/tests.scm (call-with-external-store): New procedure. (with-external-store): New macro. * tests/pack.scm (%store): Remove. (test-assertm): Add 'store' parameter. ("self-contained-tarball"): Wrap in 'with-external-store'. * tests/guix-pack.sh: Connect to the external store, if possible, by setting NIX_STORE_DIR and GUIX_DAEMON_SOCKET. Remove most uses of '--bootstrap'. --- tests/guix-pack.sh | 30 ++++++++++++++-------- tests/pack.scm | 75 ++++++++++++++++++++++++++++-------------------------- 2 files changed, 58 insertions(+), 47 deletions(-) (limited to 'tests') diff --git a/tests/guix-pack.sh b/tests/guix-pack.sh index bf367fa429..cd721a60e9 100644 --- a/tests/guix-pack.sh +++ b/tests/guix-pack.sh @@ -1,5 +1,6 @@ # GNU Guix --- Functional package management for GNU # Copyright © 2018 Chris Marusich +# Copyright © 2018 Ludovic Courtès # # This file is part of GNU Guix. # @@ -28,26 +29,33 @@ fi guix pack --version -# FIXME: Starting from commit 66e9944e078cbb9e0d618377dd6df6e639640efa, -# '--bootstrap' is mostly ineffective since 'guix pack' produces derivations -# that refer to guile-sqlite3 and libgcrypt. For now we just skip the test. -exit 77 +# Starting from commit 66e9944e078cbb9e0d618377dd6df6e639640efa, 'guix pack' +# produces derivations that refer to guile-sqlite3 and libgcrypt. To make +# that relatively inexpensive, run the test in the user's global store if +# possible, on the grounds that binaries may already be there or can be built +# or downloaded inexpensively. -# Use --no-substitutes because we need to verify we can do this ourselves. -GUIX_BUILD_OPTIONS="--no-substitutes" -export GUIX_BUILD_OPTIONS +NIX_STORE_DIR="`guile -c '(use-modules (guix config))(display %storedir)'`" +localstatedir="`guile -c '(use-modules (guix config))(display %localstatedir)'`" +GUIX_DAEMON_SOCKET="$localstatedir/guix/daemon-socket/socket" +export NIX_STORE_DIR GUIX_DAEMON_SOCKET + +if ! guile -c '(use-modules (guix)) (exit (false-if-exception (open-connection)))' +then + exit 77 +fi # Build a tarball with no compression. -guix pack --compression=none --bootstrap guile-bootstrap +guix pack --compression=none guile-bootstrap # Build a tarball (with compression). Check that '-e' works as well. -out1="`guix pack --bootstrap guile-bootstrap`" -out2="`guix pack --bootstrap -e '(@ (gnu packages bootstrap) %bootstrap-guile)'`" +out1="`guix pack guile-bootstrap`" +out2="`guix pack -e '(@ (gnu packages bootstrap) %bootstrap-guile)'`" test -n "$out1" test "$out1" = "$out2" # Build a tarball with a symlink. -the_pack="`guix pack --bootstrap -S /opt/gnu/bin=bin guile-bootstrap`" +the_pack="`guix pack -S /opt/gnu/bin=bin guile-bootstrap`" # Try to extract it. Note: we cannot test whether /opt/gnu/bin/guile itself # exists because /opt/gnu/bin may be an absolute symlink to a store item that diff --git a/tests/pack.scm b/tests/pack.scm index c57c6848ff..7f867894c2 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -29,15 +29,12 @@ #:use-module (gnu packages bootstrap) #:use-module (srfi srfi-64)) -(define %store - (open-connection-for-tests)) - ;; Globally disable grafts because they can trigger early builds. (%graft? #f) -(define-syntax-rule (test-assertm name exp) +(define-syntax-rule (test-assertm name store exp) (test-assert name - (run-with-store %store exp + (run-with-store store exp #:guile-for-build (%guile-for-build)))) (define %gzip-compressor @@ -51,37 +48,43 @@ (test-begin "pack") -;; FIXME: The following test would rebuild the world (and likely fail) as a -;; consequence of commit c45477d2a1a651485feede20fe0f3d15aec48b39 (and related -;; changes) that made guile-sqlite3 a dependency of the derivation. -;; See . -(test-skip 1) +;; The following test needs guile-sqlite3, libgcrypt, etc. as a consequence of +;; commit c45477d2a1a651485feede20fe0f3d15aec48b39 and related changes. Thus, +;; run it on the user's store, if it's available, on the grounds that these +;; dependencies may be already there, or we can get substitutes or build them +;; quite inexpensively; see . -(test-assertm "self-contained-tarball" - (mlet* %store-monad - ((profile (profile-derivation (packages->manifest - (list %bootstrap-guile)) - #:hooks '() - #:locales? #f)) - (tarball (self-contained-tarball "pack" profile - #:symlinks '(("/bin/Guile" - -> "bin/guile")) - #:compressor %gzip-compressor - #:archiver %tar-bootstrap)) - (check (gexp->derivation - "check-tarball" - #~(let ((bin (string-append "." #$profile "/bin"))) - (setenv "PATH" - (string-append #$%tar-bootstrap "/bin")) - (system* "tar" "xvf" #$tarball) - (mkdir #$output) - (exit - (and (file-exists? (string-append bin "/guile")) - (string=? (string-append #$%bootstrap-guile "/bin") - (readlink bin)) - (string=? (string-append ".." #$profile - "/bin/guile") - (readlink "bin/Guile")))))))) - (built-derivations (list check)))) +(with-external-store store + (unless store (tests-skip 1)) + (test-assertm "self-contained-tarball" store + (mlet* %store-monad + ((profile (profile-derivation (packages->manifest + (list %bootstrap-guile)) + #:hooks '() + #:locales? #f)) + (tarball (self-contained-tarball "pack" profile + #:symlinks '(("/bin/Guile" + -> "bin/guile")) + #:compressor %gzip-compressor + #:archiver %tar-bootstrap)) + (check (gexp->derivation + "check-tarball" + #~(let ((bin (string-append "." #$profile "/bin"))) + (setenv "PATH" + (string-append #$%tar-bootstrap "/bin")) + (system* "tar" "xvf" #$tarball) + (mkdir #$output) + (exit + (and (file-exists? (string-append bin "/guile")) + (string=? (string-append #$%bootstrap-guile "/bin") + (readlink bin)) + (string=? (string-append ".." #$profile + "/bin/guile") + (readlink "bin/Guile")))))))) + (built-derivations (list check))))) (test-end) + +;; Local Variables: +;; eval: (put 'test-assertm 'scheme-indent-function 2) +;; End: -- cgit v1.2.3