01/02: guix system: 'reconfigure' loads and starts new services.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 240b57f0ca576708ebf6cfa0dfe2803fa9ff2323
Author: Ludovic Courtès <address@hidden>
Date:   Wed Feb 3 21:59:47 2016 +0100

    guix system: 'reconfigure' loads and starts new services.
    
    Partly fixes <http://bugs.gnu.org/22039>.
    
    * gnu/services/herd.scm: New file.
    * gnu-system.am (GNU_SYSTEM_MODULES): Add it.
    * gnu/services/shepherd.scm (shepherd-service-canonical-name): New
    procedure.
    (shepherd-service-file): Export.
    * guix/scripts/system.scm (upgrade-shepherd-services): New procedure.
    (switch-to-system): Use it.
    * guix/ui.scm (info): New procedure.
    * doc/guix.texi (Invoking guix system): Mention system services.
---
 doc/guix.texi             |    6 ++
 gnu-system.am             |    1 +
 gnu/services/herd.scm     |  189 +++++++++++++++++++++++++++++++++++++++++++++
 gnu/services/shepherd.scm |    6 ++
 guix/scripts/system.scm   |   72 +++++++++++++++--
 guix/ui.scm               |    2 +
 6 files changed, 269 insertions(+), 7 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 11664f4..65f00ce 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -9211,17 +9211,23 @@ running GuixSD.}.
 
 This effects all the configuration specified in @var{file}: user
 accounts, system services, global package list, setuid programs, etc.
+The command starts system services specified in @var{file} that are not
+currently running; if a service is currently running, it does not
+attempt to upgrade it since it would not be possible without stopping it
+first.
 
 It also adds a GRUB menu entry for the new OS configuration, and moves
 entries for older configurations to a submenu---unless
 @option{--no-grub} is passed.
 
address@hidden Note
 @c The paragraph below refers to the problem discussed at
 @c <http://lists.gnu.org/archive/html/guix-devel/2014-08/msg00057.html>.
 It is highly recommended to run @command{guix pull} once before you run
 @command{guix system reconfigure} for the first time (@pxref{Invoking
 guix pull}).  Failing to do that you would see an older version of Guix
 once @command{reconfigure} has completed.
address@hidden quotation
 
 @item build
 Build the operating system's derivation, which includes all the
diff --git a/gnu-system.am b/gnu-system.am
index d282be3..66cd039 100644
--- a/gnu-system.am
+++ b/gnu-system.am
@@ -366,6 +366,7 @@ GNU_SYSTEM_MODULES =                                \
   gnu/services/mail.scm                                \
   gnu/services/networking.scm                  \
   gnu/services/shepherd.scm                    \
+  gnu/services/herd.scm                                \
   gnu/services/ssh.scm                         \
   gnu/services/web.scm                         \
   gnu/services/xorg.scm                                \
diff --git a/gnu/services/herd.scm b/gnu/services/herd.scm
new file mode 100644
index 0000000..89a93a1
--- /dev/null
+++ b/gnu/services/herd.scm
@@ -0,0 +1,189 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 Ludovic Courtès <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu services herd)
+  #:use-module (guix ui)
+  #:use-module (guix utils)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:use-module (ice-9 match)
+  #:export (current-services
+            unload-services
+            unload-service
+            load-services
+            start-service))
+
+;;; Commentary:
+;;;
+;;; This module provides an interface to the GNU Shepherd, similar to the
+;;; 'herd' command.  Essentially it implements a subset of the (shepherd comm)
+;;; module, but focusing only on the parts relevant to 'guix system
+;;; reconfigure'.
+;;;
+;;; Code:
+
+(define %shepherd-socket-file
+  "/var/run/shepherd/socket")
+
+(define* (open-connection #:optional (file %shepherd-socket-file))
+  "Open a connection to the daemon, using the Unix-domain socket at FILE, and
+return the socket."
+  ;; The protocol is sexp-based and UTF-8-encoded.
+  (with-fluids ((%default-port-encoding "UTF-8"))
+    (let ((sock    (socket PF_UNIX SOCK_STREAM 0))
+          (address (make-socket-address PF_UNIX file)))
+      (catch 'system-error
+        (lambda ()
+          (connect sock address)
+          (setvbuf sock _IOFBF 1024)
+          sock)
+        (lambda (key proc format-string format-args errno . rest)
+          (warning (_ "cannot connect to ~a: ~a~%") file
+                   (apply format #f format-string format-args))
+          #f)))))
+
+(define-syntax-rule (with-shepherd connection body ...)
+  "Evaluate BODY... with CONNECTION bound to an open socket to PID 1."
+  (let ((connection (open-connection)))
+    (and connection
+         (dynamic-wind
+           (const #t)
+           (lambda ()
+             body ...)
+           (const #t)))))
+
+(define (report-action-error error)
+  "Report ERROR, an sexp received by a shepherd client in reply to COMMAND, a
+command object."
+  (match error
+    (('error ('version 0 x ...) 'service-not-found service)
+     (report-error (_ "service '~a' could not be found")
+                   service))
+    (('error ('version 0 x ...) 'action-not-found action service)
+     (report-error (_ "service '~a' does not have an action '~a'")
+                   service action))
+    (('error ('version 0 x ...) 'action-exception action service
+             key (args ...))
+     (report-error (_ "exception caught while executing '~a' \
+on service '~a':")
+                   action service)
+     (print-exception (current-error-port) #f key args))
+    (('error . _)
+     (report-error (_ "something went wrong: ~s")
+                   error))
+    (#f                                           ;not an error
+     #t)))
+
+(define (display-message message)
+  ;; TRANSLATORS: Nothing to translate here.
+  (info (_ "shepherd: ~a~%") message))
+
+(define* (invoke-action service action arguments cont)
+  "Invoke ACTION on SERVICE with ARGUMENTS.  On success, call CONT with the
+result.  Otherwise return #f."
+  (with-shepherd sock
+    (write `(shepherd-command (version 0)
+                              (action ,action)
+                              (service ,service)
+                              (arguments ,arguments)
+                              (directory ,(getcwd)))
+           sock)
+    (force-output sock)
+
+    (match (read sock)
+      (('reply ('version 0 _ ...) ('result (result)) ('error #f)
+               ('messages messages))
+       (for-each display-message messages)
+       (cont result))
+      (('reply ('version 0 x ...) ('result y) ('error error)
+               ('messages messages))
+       (for-each display-message messages)
+       (report-action-error error)
+       #f)
+      (x
+       (warning (_ "invalid shepherd reply~%"))
+       #f))))
+
+(define-syntax-rule (with-shepherd-action service (action args ...)
+                      result body ...)
+  (invoke-action service action (list args ...)
+                 (lambda (result) body ...)))
+
+(define-syntax alist-let*
+  (syntax-rules ()
+    "Bind the given KEYs in EXP to the corresponding items in ALIST.  ALIST
+is assumed to be a list of two-element tuples rather than a traditional list
+of pairs."
+    ((_ alist (key ...) exp ...)
+     (let ((key (and=> (assoc-ref alist 'key) car)) ...)
+       exp ...))))
+
+(define (current-services)
+  "Return two lists: the list of currently running services, and the list of
+currently stopped services."
+  (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))
+      (x
+       (warning (_ "failed to obtain list of shepherd services~%"))
+       (values #f #f)))))
+
+(define (unload-service service)
+  "Unload SERVICE, a symbol name; return #t on success."
+  (with-shepherd-action 'root ('unload (symbol->string service)) result
+    result))
+
+(define (%load-file file)
+  "Load FILE in the Shepherd."
+  (with-shepherd-action 'root ('load file) result
+    result))
+
+(define (eval-there exp)
+  "Eval EXP in the Shepherd."
+  (with-shepherd-action 'root ('eval (object->string exp)) result
+    result))
+
+(define (load-services files)
+  "Load and register the services from FILES, where FILES contain code that
+returns a shepherd <service> object."
+  (eval-there `(register-services
+                ,@(map (lambda (file)
+                         `(primitive-load ,file))
+                       files))))
+
+(define (start-service name)
+  (with-shepherd-action name ('start) result
+    result))
+
+;; Local Variables:
+;; eval: (put 'alist-let* 'scheme-indent-function 2)
+;; eval: (put 'with-shepherd 'scheme-indent-function 1)
+;; eval: (put 'with-shepherd-action 'scheme-indent-function 3)
+;; End:
+
+;;; herd.scm ends here
diff --git a/gnu/services/shepherd.scm b/gnu/services/shepherd.scm
index 36ed9eb..6cf15a5 100644
--- a/gnu/services/shepherd.scm
+++ b/gnu/services/shepherd.scm
@@ -40,6 +40,7 @@
             shepherd-service?
             shepherd-service-documentation
             shepherd-service-provision
+            shepherd-service-canonical-name
             shepherd-service-requirement
             shepherd-service-respawn?
             shepherd-service-start
@@ -51,6 +52,8 @@
             %default-imported-modules
             %default-modules
 
+            shepherd-service-file
+
             shepherd-service-back-edges))
 
 ;;; Commentary:
@@ -139,6 +142,9 @@ for a service that extends SHEPHERD-ROOT-SERVICE-TYPE and 
nothing else."
   (imported-modules shepherd-service-imported-modules  ;list of module names
                     (default %default-imported-modules)))
 
+(define (shepherd-service-canonical-name service)
+  "Return the 'canonical name' of SERVICE."
+  (first (shepherd-service-provision service)))
 
 (define (assert-valid-graph services)
   "Raise an error if SERVICES does not define a valid shepherd service graph,
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index e31eec6..e13355d 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015 Ludovic Courtès <address@hidden>
+;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <address@hidden>
 ;;; Copyright © 2016 Alex Kost <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -41,8 +41,10 @@
   #:use-module (gnu system grub)
   #:use-module (gnu services)
   #:use-module (gnu services shepherd)
+  #:use-module (gnu services herd)
   #:use-module (gnu packages grub)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
@@ -209,6 +211,62 @@ the ownership of '~a' may be incorrect!~%")
       (lambda ()
         (environ env)))))
 
+(define (upgrade-shepherd-services os)
+  "Upgrade the Shepherd (PID 1) by unloading obsolete services and loading new
+services specified in OS and not currently running.
+
+This is currently very conservative in that it does not stop or unload any
+running service.  Unloading or stopping the wrong service ('udev', say) could
+bring the system down."
+  (define (essential? service)
+    (memq service '(root shepherd)))
+
+  (define new-services
+    (service-parameters
+     (fold-services (operating-system-services os)
+                    #:target-type shepherd-root-service-type)))
+
+  (define new-service-names
+    (map (compose first shepherd-service-provision)
+         new-services))
+
+  (let-values (((running stopped) (current-services)))
+    (define to-load
+      ;; Only load services that are either new or currently stopped.
+      (remove (lambda (service)
+                (memq (first (shepherd-service-provision service))
+                      running))
+              new-services))
+    (define 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)))))
+
+    (for-each (lambda (unload)
+                (info (_ "unloading service '~a'...~%") unload)
+                (unload-service unload))
+              to-unload)
+
+    (with-monad %store-monad
+      (munless (null? to-load)
+        (let ((to-load-names  (map shepherd-service-canonical-name to-load))
+              (to-start       (filter shepherd-service-auto-start? to-load)))
+          (info (_ "loading new services:~{ ~a~}...~%") to-load-names)
+          (mlet %store-monad ((files (mapm %store-monad shepherd-service-file
+                                           to-load)))
+            (load-services (map derivation->output-path files))
+
+            (for-each start-service
+                      (map shepherd-service-canonical-name to-start))
+            (return #t)))))))
+
 (define* (switch-to-system os
                            #:optional (profile %system-profile))
   "Make a new generation of PROFILE pointing to the directory of OS, switch to
@@ -225,14 +283,14 @@ it atomically, and then run OS's activation script."
 
       ;; The activation script may change $PATH, among others, so protect
       ;; against that.
-      (return (save-environment-excursion
-               ;; Tell 'activate-current-system' what the new system is.
-               (setenv "GUIX_NEW_SYSTEM" system)
+      (save-environment-excursion
+       ;; Tell 'activate-current-system' what the new system is.
+       (setenv "GUIX_NEW_SYSTEM" system)
 
-               (primitive-load (derivation->output-path script))))
+       (primitive-load (derivation->output-path script)))
 
-      ;; TODO: Run 'deco reload ...'.
-      )))
+      ;; Finally, try to update system services.
+      (upgrade-shepherd-services os))))
 
 (define-syntax-rule (unless-file-not-found exp)
   (catch 'system-error
diff --git a/guix/ui.scm b/guix/ui.scm
index 6fd16bb..7310773 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -95,6 +95,7 @@
             program-name
             guix-warning-port
             warning
+            info
             guix-main))
 
 ;;; Commentary:
@@ -153,6 +154,7 @@ messages."
                      args (... ...))))))))
 
 (define-diagnostic warning "warning: ") ; emit a warning
+(define-diagnostic info "")
 
 (define-diagnostic report-error "error: ")
 (define-syntax-rule (leave args ...)