gnu: Add openjdk12.

[jackhill/guix/guix.git] / gnu / services / herd.scm

diff --git a/gnu/services/herd.scm b/gnu/services/herd.scm
index f8d60a4..0008746 100644 (file)
--- a/gnu/services/herd.scm
+++ b/gnu/services/herd.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -45,11 +45,14 @@
             live-service-requirement
             live-service-running
 
+            with-shepherd-action
             current-services
             unload-services
             unload-service
             load-services
-            start-service))
+            load-services/safe
+            start-service
+            stop-service))
 
 ;;; Commentary:
 ;;;
@@ -73,7 +76,7 @@ return the socket."
       (catch 'system-error
         (lambda ()
           (connect sock address)
-          (setvbuf sock _IOFBF 1024)
+          (setvbuf sock 'block 1024)
           sock)
         (lambda args
           (close-port sock)
@@ -82,7 +85,12 @@ return the socket."
 (define-syntax-rule (with-shepherd connection body ...)
   "Evaluate BODY... with CONNECTION bound to an open socket to PID 1."
   (let ((connection (open-connection)))
-    body ...))
+    (dynamic-wind
+      (const #t)
+      (lambda ()
+        body ...)
+      (lambda ()
+        (close-port connection)))))
 
 (define-condition-type &shepherd-error &error
   shepherd-error?)
@@ -135,7 +143,8 @@ does not denote an error."
 
 (define* (invoke-action service action arguments cont)
   "Invoke ACTION on SERVICE with ARGUMENTS.  On success, call CONT with the
-result.  Otherwise return #f."
+list of results (one result per instance with the name SERVICE).  Otherwise
+return #f."
   (with-shepherd sock
     (write `(shepherd-command (version 0)
                               (action ,action)
@@ -146,7 +155,7 @@ result.  Otherwise return #f."
     (force-output sock)
 
     (match (read sock)
-      (('reply ('version 0 _ ...) ('result (result)) ('error #f)
+      (('reply ('version 0 _ ...) ('result result) ('error #f)
                ('messages messages))
        (for-each display-message messages)
        (cont result))
@@ -161,6 +170,8 @@ result.  Otherwise return #f."
 
 (define-syntax-rule (with-shepherd-action service (action args ...)
                       result body ...)
+  "Invoke ACTION on SERVICE with the given ARGS, and evaluate BODY with RESULT
+bound to the action's result."
   (invoke-action service action (list args ...)
                  (lambda (result) body ...)))
 
@@ -185,30 +196,34 @@ of pairs."
   "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 _ ...) _ ...) ...)
-       (map (lambda (service)
-              (alist-let* service (provides requires running)
-                (live-service provides requires running)))
-            services))
-      (x
-       #f))))
+  (with-shepherd-action 'root ('status) results
+    ;; We get a list of results, one for each service with the name 'root'.
+    ;; In practice there's only one such service though.
+    (match results
+      ((services _ ...)
+       (match services
+         ((('service ('version 0 _ ...) _ ...) ...)
+          (map (lambda (service)
+                 (alist-let* service (provides requires running)
+                   (live-service provides requires running)))
+               services))
+         (x
+          #f))))))
 
 (define (unload-service service)
   "Unload SERVICE, a symbol name; return #t on success."
   (with-shepherd-action 'root ('unload (symbol->string service)) result
-    result))
+    (first result)))
 
 (define (%load-file file)
   "Load FILE in the Shepherd."
   (with-shepherd-action 'root ('load file) result
-    result))
+    (first result)))
 
 (define (eval-there exp)
   "Eval EXP in the Shepherd."
   (with-shepherd-action 'root ('eval (object->string exp)) result
-    result))
+    (first result)))
 
 (define (load-services files)
   "Load and register the services from FILES, where FILES contain code that
@@ -218,8 +233,32 @@ returns a shepherd <service> object."
                          `(primitive-load ,file))
                        files))))
 
-(define (start-service name)
-  (with-shepherd-action name ('start) result
+(define (load-services/safe files)
+  "This is like 'load-services', but make sure only the subset of FILES that
+can be safely reloaded is actually reloaded.
+
+This is done to accommodate the Shepherd < 0.15.0 where services lacked the
+'replacement' slot, and where 'register-services' would throw an exception
+when passed a service with an already-registered name."
+  (eval-there `(let* ((services     (map primitive-load ',files))
+                      (slots        (map slot-definition-name
+                                         (class-slots <service>)))
+                      (can-replace? (memq 'replacement slots)))
+                 (define (registered? service)
+                   (not (null? (lookup-services (canonical-name service)))))
+
+                 (apply register-services
+                        (if can-replace?
+                            services
+                            (remove registered? services))))))
+
+(define* (start-service name #:optional (arguments '()))
+  (invoke-action name 'start arguments
+                 (lambda (result)
+                   result)))
+
+(define (stop-service name)
+  (with-shepherd-action name ('stop) result
     result))
 
 ;; Local Variables: