ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-24 21:38:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

services: herd: Provide <live-service> objects.

Browse source 
* gnu/services/herd.scm (<live-service>): New record type.
(current-services): Change to return a single value: #f or a list of
<live-service>.
* guix/scripts/system.scm (call-with-service-upgrade-info): Adjust
accordingly.
* gnu/tests/base.scm (run-basic-test)["shepherd services"]: Adjust
accordingly.
This commit is contained in:
Ludovic Courtès 2016-08-30 17:59:15 +02:00
parent 1bc4d0c266
commit 183605c853
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
3 changed files with 57 additions and 43 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

37
gnu/services/herd.scm
View file

@ -17,8 +17,8 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu services herd) (define-module (gnu services herd)
#:use-module (guix combinators)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
#:use-module (srfi srfi-34) #:use-module (srfi srfi-34)
#:use-module (srfi srfi-35) #:use-module (srfi srfi-35)
@ -37,6 +37,11 @@ (define-module (gnu services herd)
unknown-shepherd-error? unknown-shepherd-error?
unknown-shepherd-error-sexp unknown-shepherd-error-sexp
live-service?
live-service-provision
live-service-requirement
live-service-running
current-services current-services
unload-services unload-services
unload-service unload-service
@ -165,25 +170,27 @@ (define-syntax alist-let*
(let ((key (and=> (assoc-ref alist 'key) car)) ...) (let ((key (and=> (assoc-ref alist 'key) car)) ...)
exp ...)))) exp ...))))
;; Information about live Shepherd services.
(define-record-type <live-service>
(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) (define (current-services)
"Return two lists: the list of currently running services, and the list of "Return the list of currently defined Shepherd services, represented as
currently stopped services. Return #f and #f if the list of services could <live-service> objects. Return #f if the list of services could not be
not be obtained." obtained."
(with-shepherd-action 'root ('status) services (with-shepherd-action 'root ('status) services
(match services (match services
((('service ('version 0 _ ...) _ ...) ...) ((('service ('version 0 _ ...) _ ...) ...)
(fold2 (lambda (service running-services stopped-services) (map (lambda (service)
(alist-let* service (provides running) (alist-let* service (provides requires running)
(if running (live-service provides requires running)))
(values (cons (first provides) running-services) services))
stopped-services)
(values running-services
(cons (first provides) stopped-services)))))
'()
'()
services))
(x (x
(values #f #f))))) #f))))
(define (unload-service service) (define (unload-service service)
"Unload SERVICE, a symbol name; return #t on success." "Unload SERVICE, a symbol name; return #t on success."

12
gnu/tests/base.scm
View file

@ -122,11 +122,13 @@ (define marionette
(operating-system-user-accounts os)))))) (operating-system-user-accounts os))))))
(test-assert "shepherd services" (test-assert "shepherd services"
(let ((services (marionette-eval '(begin (let ((services (marionette-eval
(use-modules (gnu services herd)) '(begin
(call-with-values current-services (use-modules (gnu services herd))
append))
marionette))) (map (compose car live-service-provision)
(current-services)))
marionette)))
(lset= eq? (lset= eq?
(pk 'services services) (pk 'services services)
'(root #$@(operating-system-shepherd-service-names os))))) '(root #$@(operating-system-shepherd-service-names os)))))

51
guix/scripts/system.scm
View file

@ -283,29 +283,34 @@ (define new-service-names
(map (compose first shepherd-service-provision) (map (compose first shepherd-service-provision)
new-services)) new-services))
(let-values (((running stopped) (current-services))) (match (current-services)
(if (and running stopped) ((services ...)
(let* ((to-load (let* ((running (map (compose first live-service-provision)
;; Only load services that are either new or currently stopped. (filter live-service-running services)))
(remove (lambda (service) (stopped (map (compose first live-service-provision)
(memq (first (shepherd-service-provision service)) (remove live-service-running services)))
running)) (to-load
new-services)) ;; Only load services that are either new or currently stopped.
(to-unload (remove (lambda (service)
;; Unload services that are (1) no longer required, or (2) are (memq (first (shepherd-service-provision service))
;; in TO-LOAD. running))
(remove essential? new-services))
(append (remove (lambda (service) (to-unload
(memq service new-service-names)) ;; Unload services that are (1) no longer required, or (2) are
(append running stopped)) ;; in TO-LOAD.
(filter (lambda (service) (remove essential?
(memq service stopped)) (append (remove (lambda (service)
(map shepherd-service-canonical-name (memq service new-service-names))
to-load)))))) (append running stopped))
(mproc to-load to-unload)) (filter (lambda (service)
(with-monad %store-monad (memq service stopped))
(warning (_ "failed to obtain list of shepherd services~%")) (map shepherd-service-canonical-name
(return #f))))) 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) (define (upgrade-shepherd-services os)
"Upgrade the Shepherd (PID 1) by unloading obsolete services and loading new "Upgrade the Shepherd (PID 1) by unloading obsolete services and loading new