guix/guix
3
4
Fork 0
mirror of git://git.savannah.gnu.org/guix.git synced 2023-12-14 03:33:07 +01:00
Code Issues Releases Wiki Activity

guix system: 'reconfigure' loads and starts new services.

Browse source 
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.
This commit is contained in:
Ludovic Courtès 2016-02-03 21:59:47 +01:00
parent 98416109d5
commit 240b57f0ca
6 changed files with 269 additions and 7 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
doc/guix.texi
View file

@ -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

1
gnu-system.am
View file

@ -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 \

189
gnu/services/herd.scm Normal file
View file

@ -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

6
gnu/services/shepherd.scm
View file

@ -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,

72
guix/scripts/system.scm
View file

@ -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

2
guix/ui.scm
View file

@ -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 ...)