diff options
| -rw-r--r-- | doc/guix.texi | 6 | ||||
| -rw-r--r-- | gnu-system.am | 1 | ||||
| -rw-r--r-- | gnu/services/herd.scm | 189 | ||||
| -rw-r--r-- | gnu/services/shepherd.scm | 6 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 72 | ||||
| -rw-r--r-- | guix/ui.scm | 2 |
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 ...) |