From b8692e4696d0d2b36466827da1e0d25d69a298af Mon Sep 17 00:00:00 2001 From: Ludovic Courtès 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 @@ (define %os-with-mapped-device %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 @@ (define %os-with-mapped-device (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: Ludovic Courtès 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. --- gnu/services/shepherd.scm | 30 ++++++++++++++++++++---------- tests/services.scm | 11 ++++++++++- 2 files changed, 30 insertions(+), 11 deletions(-) (limited to 'tests') diff --git a/gnu/services/shepherd.scm b/gnu/services/shepherd.scm index a14f51592a..3cfca8574e 100644 --- a/gnu/services/shepherd.scm +++ b/gnu/services/shepherd.scm @@ -52,6 +52,7 @@ (define-module (gnu services shepherd) shepherd-service-file + shepherd-service-lookup-procedure shepherd-service-back-edges)) ;;; Commentary: @@ -249,20 +250,29 @@ (define config (gexp->file "shepherd.conf" config))) +(define* (shepherd-service-lookup-procedure services + #:optional + (provision + shepherd-service-provision)) + "Return a procedure that, when passed a symbol, return the item among +SERVICES that provides this symbol. PROVISION must be a one-argument +procedure that takes a service and returns the list of symbols it provides." + (let ((services (fold (lambda (service result) + (fold (cut vhash-consq <> service <>) + result + (provision service))) + vlist-null + services))) + (lambda (name) + (match (vhash-assq name services) + ((_ . service) service) + (#f #f))))) + (define (shepherd-service-back-edges services) "Return a procedure that, when given a from SERVICES, returns the list of that depend on it." (define provision->service - (let ((services (fold (lambda (service result) - (fold (cut vhash-consq <> service <>) - result - (shepherd-service-provision service))) - vlist-null - services))) - (lambda (name) - (match (vhash-assq name services) - ((_ . service) service) - (#f #f))))) + (shepherd-service-lookup-procedure services)) (define edges (fold (lambda (service edges) 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 @@ (define-module (test-services) (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: Ludovic Courtès 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. --- guix/scripts/system.scm | 56 +++++++++++++++++++++++++++---------------------- tests/system.scm | 5 +++-- 2 files changed, 34 insertions(+), 27 deletions(-) (limited to 'tests') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index a006b2d54e..80f62fb109 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -273,41 +273,45 @@ (define (report-shepherd-error error) #t))) (define (service-upgrade live target) - "Return two values: the names of the subset of LIVE (a list of -) that needs to be unloaded, and the subset of TARGET (a list of -) that needs to be loaded." + "Return two values: the subset of LIVE (a list of ) that needs +to be unloaded, and the subset of TARGET (a list of ) that +needs to be loaded." (define (essential? service) - (memq service '(root shepherd))) + (memq (first (live-service-provision service)) + '(root shepherd))) - (define new-service-names - (map (compose first shepherd-service-provision) - target)) + (define lookup-target + (shepherd-service-lookup-procedure target + shepherd-service-provision)) - (define running - (map (compose first live-service-provision) - (filter live-service-running live))) + (define lookup-live + (shepherd-service-lookup-procedure live + live-service-provision)) - (define stopped - (map (compose first live-service-provision) - (remove live-service-running live))) + (define (running? service) + (and=> (lookup-live (shepherd-service-canonical-name service)) + live-service-running)) + + (define (stopped service) + (match (lookup-live (shepherd-service-canonical-name service)) + (#f #f) + (service (and (not (live-service-running service)) + service)))) + + (define (obsolete? service) + (match (lookup-target (first (live-service-provision service))) + (#f #t) + (_ #f))) (define to-load ;; Only load services that are either new or currently stopped. - (remove (lambda (service) - (memq (first (shepherd-service-provision service)) - running)) - target)) + (remove running? target)) (define to-unload ;; Unload services that are (1) no longer required, or (2) are in TO-LOAD. (remove essential? - (append (remove (lambda (service) - (memq service new-service-names)) - (append running stopped)) - (filter (lambda (service) - (memq service stopped)) - (map shepherd-service-canonical-name - to-load))))) + (append (filter obsolete? live) + (filter-map stopped to-load)))) (values to-unload to-load)) @@ -319,7 +323,9 @@ (define (call-with-service-upgrade-info new-services mproc) ((services ...) (let-values (((to-unload to-load) (service-upgrade services new-services))) - (mproc to-load to-unload))) + (mproc to-load + (map (compose first live-service-provision) + to-unload)))) (#f (with-monad %store-monad (warning (_ "failed to obtain list of shepherd services~%")) 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 @@ (define service-upgrade 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 @@ (define service-upgrade (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: Ludovic Courtès 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. --- guix/scripts/system.scm | 7 ++++++- tests/system.scm | 32 ++++++++++++++++++++++++++++++++ 2 files changed, 38 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 80f62fb109..bcf19dbb7e 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -298,9 +298,14 @@ (define (stopped service) (service (and (not (live-service-running service)) service)))) + (define live-service-dependents + (shepherd-service-back-edges live + #:provision live-service-provision + #:requirement live-service-requirement)) + (define (obsolete? service) (match (lookup-target (first (live-service-provision service))) - (#f #t) + (#f (every obsolete? (live-service-dependents service))) (_ #f))) (define to-load 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 @@ (define service-upgrade (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: Ludovic Courtès 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. --- gnu/services/shepherd.scm | 52 ++++++++++++++++++++++++++++++++++- guix/scripts/system.scm | 50 +--------------------------------- tests/services.scm | 68 ++++++++++++++++++++++++++++++++++++++++++++++ tests/system.scm | 69 +---------------------------------------------- 4 files changed, 121 insertions(+), 118 deletions(-) (limited to 'tests') diff --git a/gnu/services/shepherd.scm b/gnu/services/shepherd.scm index 426b0e7290..3273184b9a 100644 --- a/gnu/services/shepherd.scm +++ b/gnu/services/shepherd.scm @@ -25,6 +25,7 @@ (define-module (gnu services shepherd) #:use-module (guix records) #:use-module (guix derivations) ;imported-modules, etc. #:use-module (gnu services) + #:use-module (gnu services herd) #:use-module (gnu packages admin) #:use-module (ice-9 match) #:use-module (ice-9 vlist) @@ -53,7 +54,8 @@ (define-module (gnu services shepherd) shepherd-service-file shepherd-service-lookup-procedure - shepherd-service-back-edges)) + shepherd-service-back-edges + shepherd-service-upgrade)) ;;; Commentary: ;;; @@ -293,4 +295,52 @@ (define edges (lambda (service) (vhash-foldq* cons '() service edges))) +(define (shepherd-service-upgrade live target) + "Return two values: the subset of LIVE (a list of ) that needs +to be unloaded, and the subset of TARGET (a list of ) that +needs to be loaded." + (define (essential? service) + (memq (first (live-service-provision service)) + '(root shepherd))) + + (define lookup-target + (shepherd-service-lookup-procedure target + shepherd-service-provision)) + + (define lookup-live + (shepherd-service-lookup-procedure live + live-service-provision)) + + (define (running? service) + (and=> (lookup-live (shepherd-service-canonical-name service)) + live-service-running)) + + (define (stopped service) + (match (lookup-live (shepherd-service-canonical-name service)) + (#f #f) + (service (and (not (live-service-running service)) + service)))) + + (define live-service-dependents + (shepherd-service-back-edges live + #:provision live-service-provision + #:requirement live-service-requirement)) + + (define (obsolete? service) + (match (lookup-target (first (live-service-provision service))) + (#f (every obsolete? (live-service-dependents service))) + (_ #f))) + + (define to-load + ;; Only load services that are either new or currently stopped. + (remove running? target)) + + (define to-unload + ;; Unload services that are (1) no longer required, or (2) are in TO-LOAD. + (remove essential? + (append (filter obsolete? live) + (filter-map stopped to-load)))) + + (values to-unload to-load)) + ;;; shepherd.scm ends here diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index bcf19dbb7e..953c6243ed 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -272,54 +272,6 @@ (define (report-shepherd-error error) ((not error) ;not an error #t))) -(define (service-upgrade live target) - "Return two values: the subset of LIVE (a list of ) that needs -to be unloaded, and the subset of TARGET (a list of ) that -needs to be loaded." - (define (essential? service) - (memq (first (live-service-provision service)) - '(root shepherd))) - - (define lookup-target - (shepherd-service-lookup-procedure target - shepherd-service-provision)) - - (define lookup-live - (shepherd-service-lookup-procedure live - live-service-provision)) - - (define (running? service) - (and=> (lookup-live (shepherd-service-canonical-name service)) - live-service-running)) - - (define (stopped service) - (match (lookup-live (shepherd-service-canonical-name service)) - (#f #f) - (service (and (not (live-service-running service)) - service)))) - - (define live-service-dependents - (shepherd-service-back-edges live - #:provision live-service-provision - #:requirement live-service-requirement)) - - (define (obsolete? service) - (match (lookup-target (first (live-service-provision service))) - (#f (every obsolete? (live-service-dependents service))) - (_ #f))) - - (define to-load - ;; Only load services that are either new or currently stopped. - (remove running? target)) - - (define to-unload - ;; Unload services that are (1) no longer required, or (2) are in TO-LOAD. - (remove essential? - (append (filter obsolete? live) - (filter-map stopped to-load)))) - - (values to-unload to-load)) - (define (call-with-service-upgrade-info new-services mproc) "Call MPROC, a monadic procedure in %STORE-MONAD, passing it the list of names of services to load (upgrade), and the list of names of services to @@ -327,7 +279,7 @@ (define (call-with-service-upgrade-info new-services mproc) (match (current-services) ((services ...) (let-values (((to-unload to-load) - (service-upgrade services new-services))) + (shepherd-service-upgrade services new-services))) (mproc to-load (map (compose first live-service-provision) to-unload)))) 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 @@ (define-module (test-services) (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 @@ (define %os-with-mapped-device %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 @@ (define service-upgrade (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 @@ (define test-source (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 @@ (define* (eval-test-with-cabal test-cabal #:key (cabal-environment '())) ('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: Ludovic Courtès 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. --- doc/guix.texi | 42 +++++++++++++++++++++++++++++++++++++++++- guix/packages.scm | 30 ++++++++++++++++++++++++++++++ tests/packages.scm | 25 +++++++++++++++++++++++++ 3 files changed, 96 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index 5448c66664..2a7fd4d041 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2574,6 +2574,45 @@ and operating system, such as @code{"mips64el-linux-gnu"} Configure and Build System}). @end deffn +@cindex package transformations +@cindex input rewriting +@cindex dependency tree rewriting +Packages can be manipulated in arbitrary ways. An example of a useful +transformation is @dfn{input rewriting}, whereby the dependency tree of +a package is rewritten by replacing specific inputs by others: + +@deffn {Scheme Procedure} package-input-rewriting @var{replacements} @ + [@var{rewrite-name}] +Return a procedure that, when passed a package, replaces its direct and +indirect dependencies (but not its implicit inputs) according to +@var{replacements}. @var{replacements} is a list of package pairs; the +first element of each pair is the package to replace, and the second one +is the replacement. + +Optionally, @var{rewrite-name} is a one-argument procedure that takes +the name of a package and returns its new name after rewrite. +@end deffn + +@noindent +Consider this example: + +@example +(define libressl-instead-of-openssl + ;; This is a procedure to replace OPENSSL by LIBRESSL, + ;; recursively. + (package-input-rewriting `((,openssl . ,libressl)))) + +(define git-with-libressl + (libressl-instead-of-openssl git)) +@end example + +@noindent +Here we first define a rewriting procedure that replaces @var{openssl} +with @var{libressl}. Then we use it to define a @dfn{variant} of the +@var{git} package that uses @var{libressl} instead of @var{openssl}. +This is exactly what the @option{--with-input} command-line option does +(@pxref{Package Transformation Options, @option{--with-input}}). + @menu * package Reference :: The package data type. * origin Reference:: The origin data type. @@ -4362,7 +4401,8 @@ This is a recursive, deep replacement. So in this example, both @code{guix} and its dependency @code{guile-json} (which also depends on @code{guile}) get rebuilt against @code{guile-next}. -However, implicit inputs are left unchanged. +This is implemented using the @code{package-input-rewriting} Scheme +procedure (@pxref{Defining Packages, @code{package-input-rewriting}}). @end table @node Additional Build Options diff --git a/guix/packages.scm b/guix/packages.scm index 3646b9ba13..d544c34cf8 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -94,6 +94,7 @@ (define-module (guix packages) package-transitive-propagated-inputs package-transitive-native-search-paths package-transitive-supported-systems + package-input-rewriting package-source-derivation package-derivation package-cross-derivation @@ -732,6 +733,35 @@ (define (bag-transitive-target-inputs bag) "Return the \"target inputs\" of BAG, recursively." (transitive-inputs (bag-target-inputs bag))) +(define* (package-input-rewriting replacements + #:optional (rewrite-name identity)) + "Return a procedure that, when passed a package, replaces its direct and +indirect dependencies (but not its implicit inputs) according to REPLACEMENTS. +REPLACEMENTS is a list of package pairs; the first element of each pair is the +package to replace, and the second one is the replacement. + +Optionally, REWRITE-NAME is a one-argument procedure that takes the name of a +package and returns its new name after rewrite." + (define (rewrite input) + (match input + ((label (? package? package) outputs ...) + (match (assq-ref replacements package) + (#f (cons* label (replace package) outputs)) + (new (cons* label new outputs)))) + (_ + input))) + + (define-memoized/v (replace p) + "Return a variant of P with its inputs rewritten." + (package + (inherit p) + (name (rewrite-name (package-name p))) + (inputs (map rewrite (package-inputs p))) + (native-inputs (map rewrite (package-native-inputs p))) + (propagated-inputs (map rewrite (package-propagated-inputs p))))) + + replace) + ;;; ;;; Package derivations. 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 @@ (define read-at (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