gnu: plantuml: Update to 1.2020.16.

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

diff --git a/gnu/services/herd.scm b/gnu/services/herd.scm
index d882c23..35d6937 100644 (file)
--- a/gnu/services/herd.scm
+++ b/gnu/services/herd.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -25,6 +25,7 @@
   #:use-module (srfi srfi-35)
   #:use-module (ice-9 match)
   #:export (%shepherd-socket-file
+            shepherd-message-port
 
             shepherd-error?
             service-not-found-error?
@@ -40,17 +41,22 @@
             unknown-shepherd-error?
             unknown-shepherd-error-sexp
 
+            live-service
             live-service?
             live-service-provision
             live-service-requirement
             live-service-running
+            live-service-canonical-name
 
+            with-shepherd-action
             current-services
             unload-services
             unload-service
             load-services
+            load-services/safe
             start-service
-            stop-service))
+            stop-service
+            restart-service))
 
 ;;; Commentary:
 ;;;
@@ -74,7 +80,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)
@@ -136,8 +142,12 @@ does not denote an error."
     (#f                                           ;not an error
      #t)))
 
+(define shepherd-message-port
+  ;; Port where messages coming from shepherd are printed.
+  (make-parameter (current-error-port)))
+
 (define (display-message message)
-  (format (current-error-port) "shepherd: ~a~%" message))
+  (format (shepherd-message-port) "shepherd: ~a~%" message))
 
 (define* (invoke-action service action arguments cont)
   "Invoke ACTION on SERVICE with ARGUMENTS.  On success, call CONT with the
@@ -168,6 +178,8 @@ 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 ...)))
 
@@ -188,6 +200,10 @@ of pairs."
   (requirement  live-service-requirement)         ;list of symbols
   (running      live-service-running))            ;#f | object
 
+(define (live-service-canonical-name service)
+  "Return the 'canonical name' of SERVICE."
+  (first (live-service-provision service)))
+
 (define (current-services)
   "Return the list of currently defined Shepherd services, represented as
 <live-service> objects.  Return #f if the list of services could not be
@@ -229,14 +245,38 @@ returns a shepherd <service> object."
                          `(primitive-load ,file))
                        files))))
 
-(define (start-service name)
-  (with-shepherd-action name ('start) result
-    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))
 
+(define (restart-service name)
+  (with-shepherd-action name ('restart) result
+    result))
+
 ;; Local Variables:
 ;; eval: (put 'alist-let* 'scheme-indent-function 2)
 ;; eval: (put 'with-shepherd 'scheme-indent-function 1)