services: nscd: Add 'invalidate' and 'statistics' actions.

* gnu/services/base.scm (nscd-action-procedure, nscd-actions): New
procedures.
(nscd-shepherd-service): Add 'modules' and 'actions' fields.
* gnu/tests/base.scm (run-basic-test)["nscd invalidate action"]
["nscd invalidate action, wrong table"]: New tests.
* doc/guix.texi (Services): Mention 'herd doc nscd action'.
(Base Services): Document the actions.

3 files changed, 88 insertions, 6 deletions

diff --git a/doc/guix.texi b/doc/guix.texi
index 4b082c5f87..0ba034e822 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -10563,11 +10563,14 @@ Start,,, shepherd, The GNU Shepherd Manual}).  For example:
 
 The above command, run as @code{root}, lists the currently defined
 services.  The @command{herd doc} command shows a synopsis of the given
-service:
+service and its associated actions:
 
 @example
 # herd doc nscd
 Run libc's name service cache daemon (nscd).
+
+# herd doc nscd action invalidate
+invalidate: Invalidate the given cache--e.g., 'hosts' for host name lookups.
 @end example
 
 The @command{start}, @command{stop}, and @command{restart} sub-commands
@@ -10965,6 +10968,27 @@ The Kmscon package to use.
 Return a service that runs the libc name service cache daemon (nscd) with the
 given @var{config}---an @code{<nscd-configuration>} object.  @xref{Name
 Service Switch}, for an example.
+
+For convenience, the Shepherd service for nscd provides the following actions:
+
+@table @code
+@item invalidate
+@cindex cache invalidation, nscd
+@cindex nscd, cache invalidation
+This invalidate the given cache.  For instance, running:
+
+@example
+herd invalidate nscd hosts
+@end example
+
+@noindent
+invalidates the host name lookup cache of nscd.
+
+@item statistics
+Running @command{herd statistics nscd} displays information about nscd usage
+and caches.
+@end table
+
 @end deffn
 
 @defvr {Scheme Variable} %nscd-default-configuration
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 3409bd352c..228d3c5926 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -1252,18 +1252,57 @@ the tty to run, among other things."
                                 (string-concatenate
                                  (map cache->config caches)))))))
 
+(define (nscd-action-procedure nscd config option)
+  ;; XXX: This is duplicated from mcron; factorize.
+  #~(lambda (_ . args)
+      ;; Run 'nscd' in a pipe so we can explicitly redirect its output to
+      ;; 'current-output-port', which at this stage is bound to the client
+      ;; connection.
+      (let ((pipe (apply open-pipe* OPEN_READ #$nscd
+                         "-f" #$config #$option args)))
+        (let loop ()
+          (match (read-line pipe 'concat)
+            ((? eof-object?)
+             (catch 'system-error
+               (lambda ()
+                 (zero? (close-pipe pipe)))
+               (lambda args
+                 ;; There's a race with the SIGCHLD handler, which could
+                 ;; call 'waitpid' before 'close-pipe' above does.  If we
+                 ;; get ECHILD, that means we lost the race, but that's
+                 ;; fine.
+                 (or (= ECHILD (system-error-errno args))
+                     (apply throw args)))))
+            (line
+             (display line)
+             (loop)))))))
+
+(define (nscd-actions nscd config)
+  "Return Shepherd actions for NSCD."
+  ;; Make this functionality available as actions because that's a simple way
+  ;; to run the right 'nscd' binary with the right config file.
+  (list (shepherd-action
+         (name 'statistics)
+         (documentation "Display statistics about nscd usage.")
+         (procedure (nscd-action-procedure nscd config "--statistics")))
+        (shepherd-action
+         (name 'invalidate)
+         (documentation
+          "Invalidate the given cache--e.g., 'hosts' for host name lookups.")
+         (procedure (nscd-action-procedure nscd config "--invalidate")))))
+
 (define (nscd-shepherd-service config)
   "Return a shepherd service for CONFIG, an <nscd-configuration> object."
-  (let ((nscd.conf     (nscd.conf-file config))
+  (let ((nscd          (file-append (nscd-configuration-glibc config)
+                                    "/sbin/nscd"))
+        (nscd.conf     (nscd.conf-file config))
         (name-services (nscd-configuration-name-services config)))
     (list (shepherd-service
            (documentation "Run libc's name service cache daemon (nscd).")
            (provision '(nscd))
            (requirement '(user-processes))
            (start #~(make-forkexec-constructor
-                     (list #$(file-append (nscd-configuration-glibc config)
-                                          "/sbin/nscd")
-                           "-f" #$nscd.conf "--foreground")
+                     (list #$nscd "-f" #$nscd.conf "--foreground")
 
                      ;; Wait for the PID file.  However, the PID file is
                      ;; written before nscd is actually listening on its
@@ -1277,7 +1316,12 @@ the tty to run, among other things."
                                                   (string-append dir "/lib"))
                                                 (list #$@name-services))
                                            ":")))))
-           (stop #~(make-kill-destructor))))))
+           (stop #~(make-kill-destructor))
+           (modules `((ice-9 popen)               ;for the actions
+                      (ice-9 rdelim)
+                      (ice-9 match)
+                      ,@%default-modules))
+           (actions (nscd-actions nscd nscd.conf))))))
 
 (define nscd-activation
   ;; Actions to take before starting nscd.
diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm
index 896d4a8f88..02882f4b46 100644
--- a/gnu/tests/base.scm
+++ b/gnu/tests/base.scm
@@ -335,6 +335,20 @@ info --version")
               (x
                (pk 'failure x #f))))
 
+          (test-equal "nscd invalidate action"
+            '(#t)                                 ;one value, #t
+            (marionette-eval '(with-shepherd-action 'nscd ('invalidate "hosts")
+                                                    result
+                                                    result)
+                             marionette))
+
+          (test-equal "nscd invalidate action, wrong table"
+            '(#f)                                 ;one value, #f
+            (marionette-eval '(with-shepherd-action 'nscd ('invalidate "xyz")
+                                                    result
+                                                    result)
+                             marionette))
+
           (test-equal "host not found"
             #f
             (marionette-eval