From b8692e4696d0d2b36466827da1e0d25d69a298af Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 30 Aug 2016 22:40:24 +0200 Subject: guix system: Extract and test the service upgrade procedure. * guix/scripts/system.scm (service-upgrade): New procedure, with code from... (call-with-service-upgrade-info): ... here. Use it. * tests/system.scm (live-service, service-upgrade): New variables. ("service-upgrade: nothing to do", "service-upgrade: one unchanged, one upgraded, one new"): New tests. --- tests/system.scm | 34 ++++++++++++++++++++++++++++++++++ 1 file changed, 34 insertions(+) (limited to 'tests') diff --git a/tests/system.scm b/tests/system.scm index b5bb9af016..dee6feda2c 100644 --- a/tests/system.scm +++ b/tests/system.scm @@ -19,6 +19,8 @@ (define-module (test-system) #:use-module (gnu) #:use-module (guix store) + #:use-module (gnu services herd) + #:use-module (gnu services shepherd) #:use-module (srfi srfi-1) #:use-module (srfi srfi-64)) @@ -59,6 +61,11 @@ %base-file-systems)) (users %base-user-accounts))) +(define live-service + (@@ (gnu services herd) live-service)) + +(define service-upgrade + (@@ (guix scripts system) service-upgrade)) (test-begin "system") @@ -114,4 +121,31 @@ (type "ext4")) %base-file-systems))))) +(test-equal "service-upgrade: nothing to do" + '(() ()) + (call-with-values + (lambda () + (service-upgrade '() '())) + list)) + +(test-equal "service-upgrade: one unchanged, one upgraded, one new" + '((bar) ;unload + ((bar) (baz))) ;load + (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. + (service-upgrade (list (live-service '(foo) '() #t) + (live-service '(bar) '() #f) + (live-service '(root) '() #t)) ;essential! + (list (shepherd-service (provision '(foo)) + (start #t)) + (shepherd-service (provision '(bar)) + (start #t)) + (shepherd-service (provision '(baz)) + (start #t))))) + (lambda (unload load) + (list unload (map shepherd-service-provision load))))) + (test-end) -- cgit v1.2.3 From a5d78eb64bcb87440a0b3ff25eec5568df0bc47c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 31 Aug 2016 12:38:38 +0200 Subject: services: shepherd: Add 'shepherd-service-lookup-procedure'. * gnu/services/shepherd.scm (shepherd-service-lookup-procedure): New procedure. (shepherd-service-back-edges)[provision->service]: Use it. * tests/services.scm ("shepherd-service-lookup-procedure"): New test. --- tests/services.scm | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/tests/services.scm b/tests/services.scm index 477a197160..12745c8006 100644 --- a/tests/services.scm +++ b/tests/services.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015 Ludovic Courtès +;;; Copyright © 2015, 2016 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -105,6 +105,15 @@ (fold-services (list s) #:target-type t1) #f))) +(test-assert "shepherd-service-lookup-procedure" + (let* ((s1 (shepherd-service (provision '(s1 s1b)) (start #f))) + (s2 (shepherd-service (provision '(s2 s2b)) (start #f))) + (s3 (shepherd-service (provision '(s3 s3b s3c)) (start #f))) + (lookup (shepherd-service-lookup-procedure (list s1 s2 s3)))) + (and (eq? (lookup 's1) (lookup 's1b) s1) + (eq? (lookup 's2) (lookup 's2b) s2) + (eq? (lookup 's3) (lookup 's3b) s3)))) + (test-assert "shepherd-service-back-edges" (let* ((s1 (shepherd-service (provision '(s1)) (start #f))) (s2 (shepherd-service (provision '(s2)) -- cgit v1.2.3 From f20a7b869668b46a011d22e4c1dcb68f855a1c62 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 31 Aug 2016 12:49:45 +0200 Subject: guix system: Use 'shepherd-service-lookup-procedure' in 'service-upgrade'. * guix/scripts/system.scm (service-upgrade)[essential?]: SERVICE is now a . [lookup-target, lookup-live, running?, stopped, obsolete?]: New procedures. [to-load, to-unload]: Use them. TO-UNLOAD is now a list of . (call-with-service-upgrade-info): Extract symbols from TO-UNLOAD. * tests/system.scm ("service-upgrade: one unchanged, one upgraded, one new"): Adjust accordingly. --- tests/system.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'tests') diff --git a/tests/system.scm b/tests/system.scm index dee6feda2c..eff997062f 100644 --- a/tests/system.scm +++ b/tests/system.scm @@ -129,7 +129,7 @@ list)) (test-equal "service-upgrade: one unchanged, one upgraded, one new" - '((bar) ;unload + '(((bar)) ;unload ((bar) (baz))) ;load (call-with-values (lambda () @@ -146,6 +146,7 @@ (shepherd-service (provision '(baz)) (start #t))))) (lambda (unload load) - (list unload (map shepherd-service-provision load))))) + (list (map live-service-provision unload) + (map shepherd-service-provision load))))) (test-end) -- cgit v1.2.3 From d4f8884fdb897e648fd7f4262b2142d8c363ac76 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 31 Aug 2016 15:23:32 +0200 Subject: guix system: Do not unload services depended on. Reported by Mark H Weaver at . * guix/scripts/system.scm (service-upgrade)[live-service-required?]: New procedure. [obsolete?]: Use it. * tests/system.scm ("service-upgrade: service depended on is not unloaded", "service-upgrade: obsolete services that depend on each other"): New tests. --- tests/system.scm | 32 ++++++++++++++++++++++++++++++++ 1 file changed, 32 insertions(+) (limited to 'tests') diff --git a/tests/system.scm b/tests/system.scm index eff997062f..9c1a13dd9b 100644 --- a/tests/system.scm +++ b/tests/system.scm @@ -149,4 +149,36 @@ (list (map live-service-provision unload) (map shepherd-service-provision load))))) +(test-equal "service-upgrade: service depended on is not unloaded" + '(((baz)) ;unload + ()) ;load + (call-with-values + (lambda () + ;; Service 'bar' is not among the target services; yet, it must not be + ;; unloaded because 'foo' depends on it. + (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) + (list (map live-service-provision unload) + (map shepherd-service-provision load))))) + +(test-equal "service-upgrade: obsolete services that depend on each other" + '(((foo) (bar) (baz)) ;unload + ((qux))) ;load + (call-with-values + (lambda () + ;; 'foo', 'bar', and 'baz' depend on each other, but all of them are + ;; obsolete, and thus should be unloaded. + (service-upgrade (list (live-service '(foo) '(bar) #t) ;obsolete + (live-service '(bar) '(baz) #t) ;obsolete + (live-service '(baz) '() #t)) ;obsolete + (list (shepherd-service (provision '(qux)) + (start #t))))) + (lambda (unload load) + (list (map live-service-provision unload) + (map shepherd-service-provision load))))) + (test-end) -- cgit v1.2.3 From 7b44cae50aed1d6d67337e9eae9f449ccd00a870 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 31 Aug 2016 15:40:00 +0200 Subject: services: shepherd: Add 'shepherd-service-upgrade', from 'guix system'. * guix/scripts/system.scm (service-upgrade): Move to... * gnu/services/shepherd.scm (shepherd-service-upgrade): ... here. * tests/system.scm ("service-upgrade: nothing to do", "service-upgrade: one unchanged, one upgraded, one new", "service-upgrade: service depended on is not unloaded", "service-upgrade: obsolete services that depend on each other"): Move to... * tests/services.scm: ... here. Adjust to 'service-upgrade' rename. --- tests/services.scm | 68 +++++++++++++++++++++++++++++++++++++++++++++++++++++ tests/system.scm | 69 +----------------------------------------------------- 2 files changed, 69 insertions(+), 68 deletions(-) (limited to 'tests') diff --git a/tests/services.scm b/tests/services.scm index 12745c8006..8993c3dafc 100644 --- a/tests/services.scm +++ b/tests/services.scm @@ -18,12 +18,17 @@ (define-module (test-services) #:use-module (gnu services) + #:use-module (gnu services herd) #:use-module (gnu services shepherd) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-64)) +(define live-service + (@@ (gnu services herd) live-service)) + + (test-begin "services") (test-assert "service-back-edges" @@ -127,4 +132,67 @@ (lset= eq? (e s2) (list s3)) (null? (e s3))))) +(test-equal "shepherd-service-upgrade: nothing to do" + '(() ()) + (call-with-values + (lambda () + (shepherd-service-upgrade '() '())) + list)) + +(test-equal "shepherd-service-upgrade: one unchanged, one upgraded, one new" + '(((bar)) ;unload + ((bar) (baz))) ;load + (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. + (shepherd-service-upgrade + (list (live-service '(foo) '() #t) + (live-service '(bar) '() #f) + (live-service '(root) '() #t)) ;essential! + (list (shepherd-service (provision '(foo)) + (start #t)) + (shepherd-service (provision '(bar)) + (start #t)) + (shepherd-service (provision '(baz)) + (start #t))))) + (lambda (unload load) + (list (map live-service-provision unload) + (map shepherd-service-provision load))))) + +(test-equal "shepherd-service-upgrade: service depended on is not unloaded" + '(((baz)) ;unload + ()) ;load + (call-with-values + (lambda () + ;; Service 'bar' is not among the target services; yet, it must not be + ;; unloaded because 'foo' depends on it. + (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) + (list (map live-service-provision unload) + (map shepherd-service-provision load))))) + +(test-equal "shepherd-service-upgrade: obsolete services that depend on each other" + '(((foo) (bar) (baz)) ;unload + ((qux))) ;load + (call-with-values + (lambda () + ;; 'foo', 'bar', and 'baz' depend on each other, but all of them are + ;; obsolete, and thus should be unloaded. + (shepherd-service-upgrade + (list (live-service '(foo) '(bar) #t) ;obsolete + (live-service '(bar) '(baz) #t) ;obsolete + (live-service '(baz) '() #t)) ;obsolete + (list (shepherd-service (provision '(qux)) + (start #t))))) + (lambda (unload load) + (list (map live-service-provision unload) + (map shepherd-service-provision load))))) + (test-end) diff --git a/tests/system.scm b/tests/system.scm index 9c1a13dd9b..ca34409be9 100644 --- a/tests/system.scm +++ b/tests/system.scm @@ -19,8 +19,6 @@ (define-module (test-system) #:use-module (gnu) #:use-module (guix store) - #:use-module (gnu services herd) - #:use-module (gnu services shepherd) #:use-module (srfi srfi-1) #:use-module (srfi srfi-64)) @@ -61,12 +59,7 @@ %base-file-systems)) (users %base-user-accounts))) -(define live-service - (@@ (gnu services herd) live-service)) - -(define service-upgrade - (@@ (guix scripts system) service-upgrade)) - + (test-begin "system") (test-assert "operating-system-store-file-system" @@ -121,64 +114,4 @@ (type "ext4")) %base-file-systems))))) -(test-equal "service-upgrade: nothing to do" - '(() ()) - (call-with-values - (lambda () - (service-upgrade '() '())) - list)) - -(test-equal "service-upgrade: one unchanged, one upgraded, one new" - '(((bar)) ;unload - ((bar) (baz))) ;load - (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. - (service-upgrade (list (live-service '(foo) '() #t) - (live-service '(bar) '() #f) - (live-service '(root) '() #t)) ;essential! - (list (shepherd-service (provision '(foo)) - (start #t)) - (shepherd-service (provision '(bar)) - (start #t)) - (shepherd-service (provision '(baz)) - (start #t))))) - (lambda (unload load) - (list (map live-service-provision unload) - (map shepherd-service-provision load))))) - -(test-equal "service-upgrade: service depended on is not unloaded" - '(((baz)) ;unload - ()) ;load - (call-with-values - (lambda () - ;; Service 'bar' is not among the target services; yet, it must not be - ;; unloaded because 'foo' depends on it. - (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) - (list (map live-service-provision unload) - (map shepherd-service-provision load))))) - -(test-equal "service-upgrade: obsolete services that depend on each other" - '(((foo) (bar) (baz)) ;unload - ((qux))) ;load - (call-with-values - (lambda () - ;; 'foo', 'bar', and 'baz' depend on each other, but all of them are - ;; obsolete, and thus should be unloaded. - (service-upgrade (list (live-service '(foo) '(bar) #t) ;obsolete - (live-service '(bar) '(baz) #t) ;obsolete - (live-service '(baz) '() #t)) ;obsolete - (list (shepherd-service (provision '(qux)) - (start #t))))) - (lambda (unload load) - (list (map live-service-provision unload) - (map shepherd-service-provision load))))) - (test-end) -- cgit v1.2.3 From 83ab1a812fc7903abdaabeca2e07bb03f8d25827 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Wed, 31 Aug 2016 09:56:00 -0500 Subject: tests: cpan: Fix mock urls. Followup to 7a62263ee5. * tests/cpan.scm (cpan->guix-package): Use "https" in mock urls. --- tests/cpan.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'tests') diff --git a/tests/cpan.scm b/tests/cpan.scm index 898081b3e5..80ff044abd 100644 --- a/tests/cpan.scm +++ b/tests/cpan.scm @@ -66,9 +66,9 @@ (lambda () (display (match url - ("http://api.metacpan.org/release/Foo-Bar" + ("https://api.metacpan.org/release/Foo-Bar" test-json) - ("http://api.metacpan.org/module/Test::Script" + ("https://api.metacpan.org/module/Test::Script" "{ \"distribution\" : \"Test-Script\" }") ("http://example.com/Foo-Bar-0.1.tar.gz" test-source) -- cgit v1.2.3 From 7060b28171d217b8091b87b92ee55c15f887e890 Mon Sep 17 00:00:00 2001 From: Efraim Flashner Date: Thu, 1 Sep 2016 13:40:49 +0300 Subject: tests: hackage: Fix mock urls. Followup to 18f747350437136b203ef6400176d1fb07b131ea. * tests/hackage.scm (hackage->guix-package): Use 'https' in mock urls. --- tests/hackage.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'tests') diff --git a/tests/hackage.scm b/tests/hackage.scm index d1ebe37405..a4de8be91e 100644 --- a/tests/hackage.scm +++ b/tests/hackage.scm @@ -110,7 +110,7 @@ library ('origin ('method 'url-fetch) ('uri ('string-append - "http://hackage.haskell.org/package/foo/foo-" + "https://hackage.haskell.org/package/foo/foo-" 'version ".tar.gz")) ('sha256 -- cgit v1.2.3 From 2a75b0b63dbf123023c1c7ae99cf01a3866612a1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 1 Sep 2016 22:35:35 +0200 Subject: packages: Add 'package-input-rewriting'. * guix/packages.scm (package-input-rewriting): New procedure. * tests/packages.scm ("package-input-rewriting"): New test. * doc/guix.texi (Defining Packages): Document it. (Package Transformation Options): Add cross-reference. --- tests/packages.scm | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) (limited to 'tests') diff --git a/tests/packages.scm b/tests/packages.scm index e9c8690730..daceea5d62 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -742,6 +742,31 @@ (and (build-derivations %store (list drv)) (file-exists? (string-append out "/bin/make"))))))) +(test-assert "package-input-rewriting" + (let* ((dep (dummy-package "chbouib" + (native-inputs `(("x" ,grep))))) + (p0 (dummy-package "example" + (inputs `(("foo" ,coreutils) + ("bar" ,grep) + ("baz" ,dep))))) + (rewrite (package-input-rewriting `((,coreutils . ,sed) + (,grep . ,findutils)) + (cut string-append "r-" <>))) + (p1 (rewrite p0)) + (p2 (rewrite p0))) + (and (not (eq? p1 p0)) + (eq? p1 p2) ;memoization + (string=? "r-example" (package-name p1)) + (match (package-inputs p1) + ((("foo" dep1) ("bar" dep2) ("baz" dep3)) + (and (eq? dep1 sed) + (eq? dep2 findutils) + (string=? (package-name dep3) "r-chbouib") + (eq? dep3 (rewrite dep)) ;memoization + (match (package-native-inputs dep3) + ((("x" dep)) + (eq? dep findutils))))))))) + (test-eq "fold-packages" hello (fold-packages (lambda (p r) (if (string=? (package-name p) "hello") -- cgit v1.2.3