Merge branch 'master' into staging

7 files changed, 127 insertions, 28 deletions

diff --git a/gnu/services/cuirass.scm b/gnu/services/cuirass.scm
index 4664a36dcf..9c62080629 100644
--- a/gnu/services/cuirass.scm
+++ b/gnu/services/cuirass.scm
@@ -4,6 +4,7 @@
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -72,9 +73,7 @@
   (one-shot?        cuirass-configuration-one-shot? ;boolean
                     (default #f))
   (fallback?        cuirass-configuration-fallback? ;boolean
-                    (default #f))
-  (load-path        cuirass-configuration-load-path
-                    (default '())))
+                    (default #f)))
 
 (define (cuirass-shepherd-service config)
   "Return a <shepherd-service> for the Cuirass service with CONFIG."
@@ -92,8 +91,7 @@
          (specs            (cuirass-configuration-specifications config))
          (use-substitutes? (cuirass-configuration-use-substitutes? config))
          (one-shot?        (cuirass-configuration-one-shot? config))
-         (fallback?        (cuirass-configuration-fallback? config))
-         (load-path        (cuirass-configuration-load-path config)))
+         (fallback?        (cuirass-configuration-fallback? config)))
      (list (shepherd-service
             (documentation "Run Cuirass.")
             (provision '(cuirass))
@@ -109,9 +107,7 @@
                             "--interval" #$(number->string interval)
                             #$@(if use-substitutes? '("--use-substitutes") '())
                             #$@(if one-shot? '("--one-shot") '())
-                            #$@(if fallback? '("--fallback") '())
-                            #$@(if (null? load-path) '()
-                                 `("--load-path" ,(string-join load-path ":"))))
+                            #$@(if fallback? '("--fallback") '()))
 
                       #:environment-variables
                       (list "GIT_SSL_CAINFO=/etc/ssl/certs/ca-certificates.crt"
diff --git a/gnu/services/herd.scm b/gnu/services/herd.scm
index d882c232cf..8c96b70731 100644
--- a/gnu/services/herd.scm
+++ b/gnu/services/herd.scm
@@ -45,6 +45,7 @@
             live-service-requirement
             live-service-running
 
+            with-shepherd-action
             current-services
             unload-services
             unload-service
@@ -168,6 +169,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 ...)))
 
diff --git a/gnu/services/mcron.scm b/gnu/services/mcron.scm
index 5bee02a587..5757bf8cf6 100644
--- a/gnu/services/mcron.scm
+++ b/gnu/services/mcron.scm
@@ -60,29 +60,71 @@
 (define (job-file job)
   (scheme-file "mcron-job" job))
 
+(define (shepherd-schedule-action mcron files)
+  "Return a Shepherd action that runs MCRON with '--schedule' for the given
+files."
+  (shepherd-action
+   (name 'schedule)
+   (documentation
+    "Display jobs that are going to be scheduled.")
+   (procedure
+    #~(lambda* (_ #:optional (n "5"))
+        ;; XXX: This is a global side effect.
+        (setenv "GUILE_AUTO_COMPILE" "0")
+
+        ;; Run 'mcron' 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 (open-pipe* OPEN_READ
+                                #$(file-append mcron "/bin/mcron")
+                                (string-append "--schedule=" n)
+                                #$@files)))
+          (let loop ()
+            (match (read-line pipe 'concat)
+              ((? eof-object?)
+               (catch 'system-error
+                 (lambda ()
+                   (zero? (close-pipe pipe)))
+                 (lambda args
+                   ;; There's with race between 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 mcron-shepherd-services
   (match-lambda
     (($ <mcron-configuration> mcron ())           ;nothing to do!
      '())
     (($ <mcron-configuration> mcron jobs)
-     (list (shepherd-service
-            (provision '(mcron))
-            (requirement '(user-processes))
-            (modules `((srfi srfi-1)
-                       (srfi srfi-26)
-                       ,@%default-modules))
-            (start #~(make-forkexec-constructor
-                      (list (string-append #$mcron "/bin/mcron")
-                            #$@(map job-file jobs))
+     (let ((files (map job-file jobs)))
+       (list (shepherd-service
+              (provision '(mcron))
+              (requirement '(user-processes))
+              (modules `((srfi srfi-1)
+                         (srfi srfi-26)
+                         (ice-9 popen)            ;for the 'schedule' action
+                         (ice-9 rdelim)
+                         (ice-9 match)
+                         ,@%default-modules))
+              (start #~(make-forkexec-constructor
+                        (list (string-append #$mcron "/bin/mcron") #$@files)
+
+                        ;; Disable auto-compilation of the job files and set a
+                        ;; sane value for 'PATH'.
+                        #:environment-variables
+                        (cons* "GUILE_AUTO_COMPILE=0"
+                               "PATH=/run/current-system/profile/bin"
+                               (remove (cut string-prefix? "PATH=" <>)
+                                       (environ)))))
+              (stop #~(make-kill-destructor))
 
-                      ;; Disable auto-compilation of the job files and set a
-                      ;; sane value for 'PATH'.
-                      #:environment-variables
-                      (cons* "GUILE_AUTO_COMPILE=0"
-                             "PATH=/run/current-system/profile/bin"
-                             (remove (cut string-prefix? "PATH=" <>)
-                                     (environ)))))
-            (stop #~(make-kill-destructor)))))))
+              (actions
+               (list (shepherd-schedule-action mcron files)))))))))
 
 (define mcron-service-type
   (service-type (name 'mcron)
diff --git a/gnu/services/monitoring.scm b/gnu/services/monitoring.scm
index 49a65db4b5..aa3b63a0e4 100644
--- a/gnu/services/monitoring.scm
+++ b/gnu/services/monitoring.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018 Sou Bunnbu <iyzsong@member.fsf.org>
+;;; Copyright © 2018 Gábor Boskovits <boskovits@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -26,7 +27,9 @@
   #:use-module (guix records)
   #:use-module (ice-9 match)
   #:export (darkstat-configuration
-            darkstat-service-type))
+            prometheus-node-exporter-configuration
+            darkstat-service-type
+            prometheus-node-exporter-service-type))
 
 
 ;;;
@@ -89,3 +92,36 @@ HTTP.")
                              (const %darkstat-accounts))
           (service-extension shepherd-root-service-type
                              (compose list darkstat-shepherd-service))))))
+
+(define-record-type* <prometheus-node-exporter-configuration>
+  prometheus-node-exporter-configuration
+  make-prometheus-node-exporter-configuration
+  prometheus-node-exporter-configuration?
+  (package prometheus-node-exporter-configuration-package
+           (default go-github-com-prometheus-node-exporter))
+  (web-listen-address prometheus-node-exporter-web-listen-address
+                      (default ":9100")))
+
+(define prometheus-node-exporter-shepherd-service
+  (match-lambda
+    (( $ <prometheus-node-exporter-configuration>
+         package web-listen-address)
+     (shepherd-service
+      (documentation "Prometheus node exporter.")
+      (provision '(prometheus-node-exporter))
+      (requirement '(networking))
+      (start #~(make-forkexec-constructor
+                (list #$(file-append package "/bin/node_exporter")
+                      "--web.listen-address" #$web-listen-address)))
+      (stop #~(make-kill-destructor))))))
+
+(define prometheus-node-exporter-service-type
+  (service-type
+   (name 'prometheus-node-exporter)
+   (description
+    "Run @command{node_exporter} to serve hardware and OS metrics to
+prometheus.")
+   (extensions
+    (list (service-extension
+           shepherd-root-service-type
+           (compose list prometheus-node-exporter-shepherd-service))))))
diff --git a/gnu/services/shepherd.scm b/gnu/services/shepherd.scm
index 6ca53faa3d..4cd2249841 100644
--- a/gnu/services/shepherd.scm
+++ b/gnu/services/shepherd.scm
@@ -49,6 +49,12 @@
             shepherd-service-auto-start?
             shepherd-service-modules
 
+            shepherd-action
+            shepherd-action?
+            shepherd-action-name
+            shepherd-action-documentation
+            shepherd-action-procedure
+
             %default-modules
 
             shepherd-service-file
@@ -146,11 +152,20 @@ DEFAULT is given, use it as the service's default value."
   (start         shepherd-service-start)               ;g-expression (procedure)
   (stop          shepherd-service-stop                 ;g-expression (procedure)
                  (default #~(const #f)))
+  (actions       shepherd-service-actions              ;list of <shepherd-action>
+                 (default '()))
   (auto-start?   shepherd-service-auto-start?          ;Boolean
                  (default #t))
   (modules       shepherd-service-modules              ;list of module names
                  (default %default-modules)))
 
+(define-record-type* <shepherd-action>
+  shepherd-action make-shepherd-action
+  shepherd-action?
+  (name          shepherd-action-name)            ;symbol
+  (procedure     shepherd-action-procedure)       ;gexp
+  (documentation shepherd-action-documentation))  ;string
+
 (define (shepherd-service-canonical-name service)
   "Return the 'canonical name' of SERVICE."
   (first (shepherd-service-provision service)))
@@ -223,7 +238,13 @@ stored."
                        #:requires '#$(shepherd-service-requirement service)
                        #:respawn? '#$(shepherd-service-respawn? service)
                        #:start #$(shepherd-service-start service)
-                       #:stop #$(shepherd-service-stop service))))))
+                       #:stop #$(shepherd-service-stop service)
+                       #:actions
+                       (make-actions
+                        #$@(map (match-lambda
+                                  (($ <shepherd-action> name proc doc)
+                                   #~(#$name #$doc #$proc)))
+                                (shepherd-service-actions service))))))))
 
 (define (shepherd-configuration-file services)
   "Return the shepherd configuration file for SERVICES."
diff --git a/gnu/services/ssh.scm b/gnu/services/ssh.scm
index f1d2be3f6b..f158fdf01f 100644
--- a/gnu/services/ssh.scm
+++ b/gnu/services/ssh.scm
@@ -455,7 +455,7 @@ of user-name/file-like tuples."
 
   (list (shepherd-service
          (documentation "OpenSSH server.")
-         (requirement '(syslogd))
+         (requirement '(syslogd loopback))
          (provision '(ssh-daemon))
          (start #~(make-forkexec-constructor #$openssh-command
                                              #:pid-file #$pid-file))
diff --git a/gnu/services/virtualization.scm b/gnu/services/virtualization.scm
index bf71e7f26a..705ed84d06 100644
--- a/gnu/services/virtualization.scm
+++ b/gnu/services/virtualization.scm
@@ -37,6 +37,7 @@
 
   #:export (libvirt-configuration
             libvirt-service-type
+            virtlog-configuration
             virtlog-service-type
 
             %qemu-platforms