aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--doc/guix.texi6
-rw-r--r--gnu-system.am1
-rw-r--r--gnu/services/herd.scm189
-rw-r--r--gnu/services/shepherd.scm6
-rw-r--r--guix/scripts/system.scm72
-rw-r--r--guix/ui.scm2
6 files changed, 269 insertions, 7 deletions
diff --git a/doc/guix.texi b/doc/guix.texi
index 11664f46f2..65f00ce0b1 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.
+@quotation 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.
+@end quotation
@item build
Build the operating system's derivation, which includes all the
diff --git a/gnu-system.am b/gnu-system.am
index d282be3deb..66cd039a7c 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 0000000000..89a93a1969
--- /dev/null
+++ b/gnu/services/herd.scm
@@ -0,0 +1,189 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; 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 36ed9eb1c0..6cf15a5e00 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 e31eec6fda..e13355d399 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 <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
;;;
;;; 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 6fd16bb9cc..7310773310 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 ...)