mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 05:18:07 -05:00
services: herd: Provide <live-service> objects.
* 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
parent
1bc4d0c266
commit
183605c853
3 changed files with 57 additions and 43 deletions
|
|
@ -17,8 +17,8 @@
|
|||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
(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 @@ (define-module (gnu services herd)
|
|||
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 @@ (define-syntax alist-let*
|
|||
(let ((key (and=> (assoc-ref alist 'key) car)) ...)
|
||||
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)
|
||||
"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
|
||||
<live-service> 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."
|
||||
|
|
|
|||
|
|
@ -122,11 +122,13 @@ (define marionette
|
|||
(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)))))
|
||||
|
|
|
|||
|
|
@ -283,29 +283,34 @@ (define new-service-names
|
|||
(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
|
||||
|
|
|
|||
Loading…
Reference in a new issue