From 7a62263ee50c9e2894ea0e746b89f04e3b6484c3 Mon Sep 17 00:00:00 2001 From: ng0 Date: Tue, 30 Aug 2016 12:57:47 +0000 Subject: import: cpan: Use tls to query api.metacpan.org. * guix/import/cpan.scm (module->dist-name, cpan-fetch-module): Use tls for api.metacpan.org. Signed-off-by: Eric Bavier --- guix/import/cpan.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm index 213a155fd6..5b7c47554a 100644 --- a/guix/import/cpan.scm +++ b/guix/import/cpan.scm @@ -83,7 +83,7 @@ "Return the base distribution module for a given module. E.g. the 'ok' module is distributed with 'Test::Simple', so (module->dist-name \"ok\") would return \"Test-Simple\"" - (assoc-ref (json-fetch (string-append "http://api.metacpan.org/module/" + (assoc-ref (json-fetch (string-append "https://api.metacpan.org/module/" module)) "distribution")) @@ -91,7 +91,7 @@ return \"Test-Simple\"" "Return an alist representation of the CPAN metadata for the perl module MODULE, or #f on failure. MODULE should be e.g. \"Test::Script\"" ;; This API always returns the latest release of the module. - (json-fetch (string-append "http://api.metacpan.org/release/" + (json-fetch (string-append "https://api.metacpan.org/release/" ;; XXX: The 'release' api requires the "release" ;; name of the package. This substitution seems ;; reasonably consistent across packages. -- cgit v1.2.3 From 18f747350437136b203ef6400176d1fb07b131ea Mon Sep 17 00:00:00 2001 From: ng0 Date: Tue, 30 Aug 2016 12:08:21 +0000 Subject: import: hackage: Default to https urls. * guix/import/hackage.scm (hackage-source-url, hackage-cabal-url): Use https for hackage.haskell.org. --- guix/import/hackage.scm | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index f07f453e11..9af78ea888 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Federico Beffa ;;; Copyright © 2016 Eric Bavier +;;; Coypright © 2016 ng0 ;;; ;;; This file is part of GNU Guix. ;;; @@ -74,7 +75,7 @@ (define (hackage-source-url name version) "Given a Hackage package NAME and VERSION, return a url to the source tarball." - (string-append "http://hackage.haskell.org/package/" name + (string-append "https://hackage.haskell.org/package/" name "/" name "-" version ".tar.gz")) (define* (hackage-cabal-url name #:optional version) @@ -82,9 +83,9 @@ tarball." .cabal file on Hackage. If VERSION is #f or missing, the url for the latest version is returned." (if version - (string-append "http://hackage.haskell.org/package/" + (string-append "https://hackage.haskell.org/package/" name "-" version "/" name ".cabal") - (string-append "http://hackage.haskell.org/package/" + (string-append "https://hackage.haskell.org/package/" name "/" name ".cabal"))) (define (hackage-name->package-name name) -- cgit v1.2.3 From 2098d0240e89ec4fae49b33ee0990a7f833576b5 Mon Sep 17 00:00:00 2001 From: David Craven Date: Thu, 25 Aug 2016 23:06:27 +0200 Subject: build: Add wrap-qt-program. * guix/build/qt-utils.scm (wrap-qt-program): New file. * Makefile.am (MODULES): Add it. --- Makefile.am | 1 + guix/build/qt-utils.scm | 40 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 41 insertions(+) create mode 100644 guix/build/qt-utils.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 8bae85e144..165dfe9727 100644 --- a/Makefile.am +++ b/Makefile.am @@ -107,6 +107,7 @@ MODULES = \ guix/build/emacs-utils.scm \ guix/build/graft.scm \ guix/build/bournish.scm \ + guix/build/qt-utils.scm \ guix/search-paths.scm \ guix/packages.scm \ guix/import/utils.scm \ diff --git a/guix/build/qt-utils.scm b/guix/build/qt-utils.scm new file mode 100644 index 0000000000..48a32674e9 --- /dev/null +++ b/guix/build/qt-utils.scm @@ -0,0 +1,40 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 David Craven +;;; +;;; 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 (guix build qt-utils) + #:use-module (guix build utils) + #:export (wrap-qt-program)) + +(define (wrap-qt-program out program) + (define (suffix env-var path) + (let ((env-val (getenv env-var))) + (if env-val (string-append env-val ":" path) path))) + + (let ((qml-path (suffix "QML2_IMPORT_PATH" + (string-append out "/qml"))) + (plugin-path (suffix "QT_PLUGIN_PATH" + (string-append out "/plugins"))) + (xdg-data-path (suffix "XDG_DATA_DIRS" + (string-append out "/share"))) + (xdg-config-path (suffix "XDG_CONFIG_DIRS" + (string-append out "/etc/xdg")))) + (wrap-program (string-append out "/bin/" program) + `("QML2_IMPORT_PATH" = (,qml-path)) + `("QT_PLUGIN_PATH" = (,plugin-path)) + `("XDG_DATA_DIRS" = (,xdg-data-path)) + `("XDG_CONFIG_DIRS" = (,xdg-config-path))))) -- cgit v1.2.3 From 183605c8533ad321ff8bba209b64071a9e84714a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 30 Aug 2016 17:59:15 +0200 Subject: services: herd: Provide objects. * gnu/services/herd.scm (): New record type. (current-services): Change to return a single value: #f or a list of . * guix/scripts/system.scm (call-with-service-upgrade-info): Adjust accordingly. * gnu/tests/base.scm (run-basic-test)["shepherd services"]: Adjust accordingly. --- gnu/services/herd.scm | 37 ++++++++++++++++++++--------------- gnu/tests/base.scm | 12 +++++++----- guix/scripts/system.scm | 51 +++++++++++++++++++++++++++---------------------- 3 files changed, 57 insertions(+), 43 deletions(-) (limited to 'guix') diff --git a/gnu/services/herd.scm b/gnu/services/herd.scm index 7a9db90012..03bfbf1d78 100644 --- a/gnu/services/herd.scm +++ b/gnu/services/herd.scm @@ -17,8 +17,8 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu services herd) - #:use-module (guix combinators) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) @@ -37,6 +37,11 @@ unknown-shepherd-error? unknown-shepherd-error-sexp + live-service? + live-service-provision + live-service-requirement + live-service-running + current-services unload-services unload-service @@ -165,25 +170,27 @@ of pairs." (let ((key (and=> (assoc-ref alist 'key) car)) ...) exp ...)))) +;; Information about live Shepherd services. +(define-record-type + (live-service provision requirement running) + live-service? + (provision live-service-provision) ;list of symbols + (requirement live-service-requirement) ;list of symbols + (running live-service-running)) ;#f | object + (define (current-services) - "Return two lists: the list of currently running services, and the list of -currently stopped services. Return #f and #f if the list of services could -not be obtained." + "Return the list of currently defined Shepherd services, represented as + objects. Return #f if the list of services could not be +obtained." (with-shepherd-action 'root ('status) services (match services ((('service ('version 0 _ ...) _ ...) ...) - (fold2 (lambda (service running-services stopped-services) - (alist-let* service (provides running) - (if running - (values (cons (first provides) running-services) - stopped-services) - (values running-services - (cons (first provides) stopped-services))))) - '() - '() - services)) + (map (lambda (service) + (alist-let* service (provides requires running) + (live-service provides requires running))) + services)) (x - (values #f #f))))) + #f)))) (define (unload-service service) "Unload SERVICE, a symbol name; return #t on success." diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm index ca6f76c0f8..41f50c0e7a 100644 --- a/gnu/tests/base.scm +++ b/gnu/tests/base.scm @@ -122,11 +122,13 @@ info --version") (operating-system-user-accounts os)))))) (test-assert "shepherd services" - (let ((services (marionette-eval '(begin - (use-modules (gnu services herd)) - (call-with-values current-services - append)) - marionette))) + (let ((services (marionette-eval + '(begin + (use-modules (gnu services herd)) + + (map (compose car live-service-provision) + (current-services))) + marionette))) (lset= eq? (pk 'services services) '(root #$@(operating-system-shepherd-service-names os))))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index a9fe7d5975..55a8e475d4 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -283,29 +283,34 @@ unload." (map (compose first shepherd-service-provision) new-services)) - (let-values (((running stopped) (current-services))) - (if (and running stopped) - (let* ((to-load - ;; Only load services that are either new or currently stopped. - (remove (lambda (service) - (memq (first (shepherd-service-provision service)) - running)) - new-services)) - (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)))))) - (mproc to-load to-unload)) - (with-monad %store-monad - (warning (_ "failed to obtain list of shepherd services~%")) - (return #f))))) + (match (current-services) + ((services ...) + (let* ((running (map (compose first live-service-provision) + (filter live-service-running services))) + (stopped (map (compose first live-service-provision) + (remove live-service-running services))) + (to-load + ;; Only load services that are either new or currently stopped. + (remove (lambda (service) + (memq (first (shepherd-service-provision service)) + running)) + new-services)) + (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)))))) + (mproc to-load to-unload))) + (#f + (with-monad %store-monad + (warning (_ "failed to obtain list of shepherd services~%")) + (return #f))))) (define (upgrade-shepherd-services os) "Upgrade the Shepherd (PID 1) by unloading obsolete services and loading new -- cgit v1.2.3 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. --- guix/scripts/system.scm | 65 +++++++++++++++++++++++++++++-------------------- tests/system.scm | 34 ++++++++++++++++++++++++++ 2 files changed, 73 insertions(+), 26 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 55a8e475d4..a006b2d54e 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -272,40 +272,53 @@ on service '~a':~%") ((not error) ;not an error #t))) -(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 -unload." +(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." (define (essential? service) (memq service '(root shepherd))) (define new-service-names (map (compose first shepherd-service-provision) - new-services)) + target)) + + (define running + (map (compose first live-service-provision) + (filter live-service-running live))) + + (define stopped + (map (compose first live-service-provision) + (remove live-service-running live))) + + (define to-load + ;; Only load services that are either new or currently stopped. + (remove (lambda (service) + (memq (first (shepherd-service-provision service)) + 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))))) + + (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 +unload." (match (current-services) ((services ...) - (let* ((running (map (compose first live-service-provision) - (filter live-service-running services))) - (stopped (map (compose first live-service-provision) - (remove live-service-running services))) - (to-load - ;; Only load services that are either new or currently stopped. - (remove (lambda (service) - (memq (first (shepherd-service-provision service)) - running)) - new-services)) - (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)))))) + (let-values (((to-unload to-load) + (service-upgrade services new-services))) (mproc to-load to-unload))) (#f (with-monad %store-monad 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 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 'guix') 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 @@ on service '~a':~%") #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 @@ unload." ((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 @@ 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: 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 'guix') 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 @@ needs to be loaded." (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 @@ (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 'guix') 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 @@ #: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 @@ shepherd-service-file shepherd-service-lookup-procedure - shepherd-service-back-edges)) + shepherd-service-back-edges + shepherd-service-upgrade)) ;;; Commentary: ;;; @@ -293,4 +295,52 @@ symbols provided/required by a service." (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 @@ on service '~a':~%") ((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 @@ unload." (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 @@ (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 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 'guix') 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 @@ 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 @@ dependencies are known to build on SYSTEM." "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 @@ (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 From 4e49163f76946503121493fafd6c0fe7b5bde030 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 1 Sep 2016 22:39:41 +0200 Subject: guix build: Rewrite '--with-input' in terms of 'package-input-rewriting'. * guix/scripts/build.scm (transform-package-inputs): Rewrite in terms of 'package-input-rewriting'. --- guix/scripts/build.scm | 30 +++++++----------------------- 1 file changed, 7 insertions(+), 23 deletions(-) (limited to 'guix') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 9a113b4ebe..86b95b4075 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -193,33 +193,17 @@ of \"guile\"." (map (lambda (spec) (match (string-tokenize spec not-equal) ((old new) - (cons old (specification->package new))) + (cons (specification->package old) + (specification->package new))) (_ (leave (_ "invalid replacement specification: ~s~%") spec)))) replacement-specs)) - (define (rewrite input) - (match input - ((label (? package? package) outputs ...) - (match (assoc-ref replacements (package-name package)) - (#f (cons* label (replace package) outputs)) - (new (cons* label new outputs)))) - (_ - input))) - - (define replace - (memoize ;XXX: use eq? - (lambda (p) - (package - (inherit p) - (inputs (map rewrite (package-inputs p))) - (native-inputs (map rewrite (package-native-inputs p))) - (propagated-inputs (map rewrite (package-propagated-inputs p))))))) - - (lambda (store obj) - (if (package? obj) - (replace obj) - obj))) + (let ((rewrite (package-input-rewriting replacements))) + (lambda (store obj) + (if (package? obj) + (rewrite obj) + obj)))) (define %transformations ;; Transformations that can be applied to things to build. The car is the -- cgit v1.2.3