diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | gnu/machine/ssh.scm | 189 | ||||
| -rw-r--r-- | gnu/services/herd.scm | 6 | ||||
| -rw-r--r-- | guix/scripts/system/reconfigure.scm | 237 | ||||
| -rw-r--r-- | tests/services.scm | 4 |
5 files changed, 256 insertions, 181 deletions
diff --git a/Makefile.am b/Makefile.am index 7fa51d17ac..0bd85e8fcf 100644 --- a/Makefile.am +++ b/Makefile.am @@ -249,6 +249,7 @@ MODULES = \ guix/scripts/describe.scm \ guix/scripts/system.scm \ guix/scripts/system/search.scm \ + guix/scripts/system/reconfigure.scm \ guix/scripts/lint.scm \ guix/scripts/challenge.scm \ guix/scripts/import/crate.scm \ diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm index 278d43c10f..552eafa9de 100644 --- a/gnu/machine/ssh.scm +++ b/gnu/machine/ssh.scm @@ -17,23 +17,21 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (gnu machine ssh) - #:use-module (gnu bootloader) #:use-module (gnu machine) #:autoload (gnu packages gnupg) (guile-gcrypt) - #:use-module (gnu services) - #:use-module (gnu services shepherd) #:use-module (gnu system) - #:use-module (guix derivations) #:use-module (guix gexp) #:use-module (guix i18n) #:use-module (guix modules) #:use-module (guix monads) #:use-module (guix records) #:use-module (guix remote) + #:use-module (guix scripts system reconfigure) #:use-module (guix ssh) #:use-module (guix store) #:use-module (ice-9 match) #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) #:use-module (srfi srfi-35) #:export (managed-host-environment-type @@ -105,118 +103,6 @@ an environment type of 'managed-host." ;;; System deployment. ;;; -(define (switch-to-system machine) - "Monadic procedure creating a new generation on MACHINE and execute the -activation script for the new system configuration." - (define (remote-exp drv script) - (with-extensions (list guile-gcrypt) - (with-imported-modules (source-module-closure '((guix config) - (guix profiles) - (guix utils))) - #~(begin - (use-modules (guix config) - (guix profiles) - (guix utils)) - - (define %system-profile - (string-append %state-directory "/profiles/system")) - - (let* ((system #$drv) - (number (1+ (generation-number %system-profile))) - (generation (generation-file-name %system-profile number))) - (switch-symlinks generation system) - (switch-symlinks %system-profile generation) - ;; The implementation of 'guix system reconfigure' saves the - ;; load path and environment here. This is unnecessary here - ;; because each invocation of 'remote-eval' runs in a distinct - ;; Guile REPL. - (setenv "GUIX_NEW_SYSTEM" system) - ;; The activation script may write to stdout, which confuses - ;; 'remote-eval' when it attempts to read a result from the - ;; remote REPL. We work around this by forcing the output to a - ;; string. - (with-output-to-string - (lambda () - (primitive-load #$script)))))))) - - (let* ((os (machine-system machine)) - (script (operating-system-activation-script os))) - (mlet* %store-monad ((drv (operating-system-derivation os))) - (machine-remote-eval machine (remote-exp drv script))))) - -;; XXX: Currently, this does NOT attempt to restart running services. This is -;; also the case with 'guix system reconfigure'. -;; -;; See <https://issues.guix.info/issue/33508>. -(define (upgrade-shepherd-services machine) - "Monadic procedure unloading and starting services on the remote as needed -to realize the MACHINE's system configuration." - (define target-services - ;; Monadic expression evaluating to a list of (name output-path) pairs for - ;; all of MACHINE's services. - (mapm %store-monad - (lambda (service) - (mlet %store-monad ((file ((compose lower-object - shepherd-service-file) - service))) - (return (list (shepherd-service-canonical-name service) - (derivation->output-path file))))) - (service-value - (fold-services (operating-system-services (machine-system machine)) - #:target-type shepherd-root-service-type)))) - - (define (remote-exp target-services) - (with-imported-modules '((gnu services herd)) - #~(begin - (use-modules (gnu services herd) - (srfi srfi-1)) - - (define running - (filter live-service-running (current-services))) - - (define (essential? service) - ;; Return #t if SERVICE is essential and should not be unloaded - ;; under any circumstance. - (memq (first (live-service-provision service)) - '(root shepherd))) - - (define (obsolete? service) - ;; Return #t if SERVICE can be safely unloaded. - (and (not (essential? service)) - (every (lambda (requirements) - (not (memq (first (live-service-provision service)) - requirements))) - (map live-service-requirement running)))) - - (define to-unload - (filter obsolete? - (remove (lambda (service) - (memq (first (live-service-provision service)) - (map first '#$target-services))) - running))) - - (define to-start - (remove (lambda (service-pair) - (memq (first service-pair) - (map (compose first live-service-provision) - running))) - '#$target-services)) - - ;; Unload obsolete services. - (for-each (lambda (service) - (false-if-exception - (unload-service service))) - to-unload) - - ;; Load the service files for any new services and start them. - (load-services/safe (map second to-start)) - (for-each start-service (map first to-start)) - - #t))) - - (mlet %store-monad ((target-services target-services)) - (machine-remote-eval machine (remote-exp target-services)))) - (define (machine-boot-parameters machine) "Monadic procedure returning a list of 'boot-parameters' for the generations of MACHINE's system profile, ordered from most recent to oldest." @@ -275,71 +161,20 @@ of MACHINE's system profile, ordered from most recent to oldest." (boot-parameters-kernel-arguments params)))))))) generations)))) -(define (install-bootloader machine) - "Create a bootloader entry for the new system generation on MACHINE, and -configure the bootloader to boot that generation by default." - (define bootloader-installer-script - (@@ (guix scripts system) bootloader-installer-script)) - - (define (remote-exp installer bootcfg bootcfg-file) - (with-extensions (list guile-gcrypt) - (with-imported-modules (source-module-closure '((gnu build install) - (guix store) - (guix utils))) - #~(begin - (use-modules (gnu build install) - (guix store) - (guix utils)) - (let* ((gc-root (string-append "/" %gc-roots-directory "/bootcfg")) - (temp-gc-root (string-append gc-root ".new"))) - - (switch-symlinks temp-gc-root gc-root) - - (unless (false-if-exception - (begin - ;; The implementation of 'guix system reconfigure' - ;; saves the load path here. This is unnecessary here - ;; because each invocation of 'remote-eval' runs in a - ;; distinct Guile REPL. - (install-boot-config #$bootcfg #$bootcfg-file "/") - ;; The installation script may write to stdout, which - ;; confuses 'remote-eval' when it attempts to read a - ;; result from the remote REPL. We work around this - ;; by forcing the output to a string. - (with-output-to-string - (lambda () - (primitive-load #$installer))))) - (delete-file temp-gc-root) - (error "failed to install bootloader")) - - (rename-file temp-gc-root gc-root) - #t))))) - - (mlet* %store-monad ((boot-parameters (machine-boot-parameters machine))) - (let* ((os (machine-system machine)) - (bootloader ((compose bootloader-configuration-bootloader - operating-system-bootloader) - os)) - (bootloader-target (bootloader-configuration-target - (operating-system-bootloader os))) - (installer (bootloader-installer-script - (bootloader-installer bootloader) - (bootloader-package bootloader) - bootloader-target - "/")) - (menu-entries (map boot-parameters->menu-entry boot-parameters)) - (bootcfg (operating-system-bootcfg os menu-entries)) - (bootcfg-file (bootloader-configuration-file bootloader))) - (machine-remote-eval machine (remote-exp installer bootcfg bootcfg-file))))) - (define (deploy-managed-host machine) "Internal implementation of 'deploy-machine' for MACHINE instances with an environment type of 'managed-host." (maybe-raise-unsupported-configuration-error machine) - (mbegin %store-monad - (switch-to-system machine) - (upgrade-shepherd-services machine) - (install-bootloader machine))) + (mlet %store-monad ((boot-parameters (machine-boot-parameters machine))) + (let* ((os (machine-system machine)) + (eval (cut machine-remote-eval machine <>)) + (menu-entries (map boot-parameters->menu-entry boot-parameters)) + (bootloader-configuration (operating-system-bootloader os)) + (bootcfg (operating-system-bootcfg os menu-entries))) + (mbegin %store-monad + (switch-to-system eval os) + (upgrade-shepherd-services eval os) + (install-bootloader eval bootloader-configuration bootcfg))))) ;;; diff --git a/gnu/services/herd.scm b/gnu/services/herd.scm index 0008746fe9..2207b2d34b 100644 --- a/gnu/services/herd.scm +++ b/gnu/services/herd.scm @@ -40,10 +40,12 @@ unknown-shepherd-error? unknown-shepherd-error-sexp + live-service live-service? live-service-provision live-service-requirement live-service-running + live-service-canonical-name with-shepherd-action current-services @@ -192,6 +194,10 @@ of pairs." (requirement live-service-requirement) ;list of symbols (running live-service-running)) ;#f | object +(define (live-service-canonical-name service) + "Return the 'canonical name' of SERVICE." + (first (live-service-provision service))) + (define (current-services) "Return the list of currently defined Shepherd services, represented as <live-service> objects. Return #f if the list of services could not be diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm new file mode 100644 index 0000000000..8c7d461585 --- /dev/null +++ b/guix/scripts/system/reconfigure.scm @@ -0,0 +1,237 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016 Alex Kost <alezost@gmail.com> +;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com> +;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> +;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2019 Christopher Baines <mail@cbaines.net> +;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.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 (guix scripts system reconfigure) + #:autoload (gnu packages gnupg) (guile-gcrypt) + #:use-module (gnu bootloader) + #:use-module (gnu services) + #:use-module (gnu services herd) + #:use-module (gnu services shepherd) + #:use-module (gnu system) + #:use-module (guix gexp) + #:use-module (guix modules) + #:use-module (guix monads) + #:use-module (guix store) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:export (switch-system-program + switch-to-system + + upgrade-services-program + upgrade-shepherd-services + + install-bootloader-program + install-bootloader)) + +;;; Commentary: +;;; +;;; This module implements the "effectful" parts of system +;;; reconfiguration. Although building a system derivation is a pure +;;; operation, a number of impure operations must be carried out for the +;;; system configuration to be realized -- chiefly, creation of generation +;;; symlinks and invocation of activation scripts. +;;; +;;; Code: + + +;;; +;;; Profile creation. +;;; + +(define* (switch-system-program os #:optional profile) + "Return an executable store item that, upon being evaluated, will create a +new generation of PROFILE pointing to the directory of OS, switch to it +atomically, and run OS's activation script." + (program-file + "switch-to-system.scm" + (with-extensions (list guile-gcrypt) + (with-imported-modules (source-module-closure '((guix config) + (guix profiles) + (guix utils))) + #~(begin + (use-modules (guix config) + (guix profiles) + (guix utils)) + + (define profile + (or #$profile (string-append %state-directory "/profiles/system"))) + + (let* ((number (1+ (generation-number profile))) + (generation (generation-file-name profile number))) + (switch-symlinks generation #$os) + (switch-symlinks profile generation) + (setenv "GUIX_NEW_SYSTEM" #$os) + (primitive-load #$(operating-system-activation-script os)))))))) + +(define* (switch-to-system eval os #:optional profile) + "Using EVAL, a monadic procedure taking a single G-Expression as an argument, +create a new generation of PROFILE pointing to the directory of OS, switch to +it atomically, and run OS's activation script." + (eval #~(primitive-load #$(switch-system-program os profile)))) + + +;;; +;;; Services. +;;; + +(define (running-services eval) + "Using EVAL, a monadic procedure taking a single G-Expression as an argument, +return the <live-service> objects that are currently running on MACHINE." + (define exp + (with-imported-modules '((gnu services herd)) + #~(begin + (use-modules (gnu services herd)) + (let ((services (current-services))) + (and services + ;; 'live-service-running' is ignored, as we can't necessarily + ;; serialize arbitrary objects. This should be fine for now, + ;; since 'machine-current-services' is not exposed publicly, + ;; and the resultant <live-service> objects are only used for + ;; resolving service dependencies. + (map (lambda (service) + (list (live-service-provision service) + (live-service-requirement service))) + services)))))) + (mlet %store-monad ((services (eval exp))) + (return (map (match-lambda + ((provision requirement) + (live-service provision requirement #f))) + services)))) + +;; XXX: Currently, this does NOT attempt to restart running services. See +;; <https://issues.guix.info/issue/33508> for details. +(define (upgrade-services-program service-files to-start to-unload to-restart) + "Return an executable store item that, upon being evaluated, will upgrade +the Shepherd (PID 1) by unloading obsolete services and loading new +services. SERVICE-FILES is a list of Shepherd service files to load, and +TO-START, TO-UNLOAD, and TO-RESTART are lists of the Shepherd services' +canonical names (symbols)." + (program-file + "upgrade-shepherd-services.scm" + (with-imported-modules '((gnu services herd)) + #~(begin + (use-modules (gnu services herd) + (srfi srfi-1)) + + ;; Load the service files for any new services. + (load-services/safe '#$service-files) + + ;; Unload obsolete services and start new services. + (for-each unload-service '#$to-unload) + (for-each start-service '#$to-start))))) + +(define* (upgrade-shepherd-services eval os) + "Using EVAL, a monadic procedure taking a single G-Expression as an argument, +upgrade the Shepherd (PID 1) by unloading obsolete services and loading new +services as defined by OS." + (define target-services + (service-value + (fold-services (operating-system-services os) + #:target-type shepherd-root-service-type))) + + (mlet* %store-monad ((live-services (running-services eval))) + (let*-values (((to-unload to-restart) + (shepherd-service-upgrade live-services target-services))) + (let* ((to-unload (map live-service-canonical-name to-unload)) + (to-restart (map shepherd-service-canonical-name to-restart)) + (to-start (lset-difference eqv? + (map shepherd-service-canonical-name + target-services) + (map live-service-canonical-name + live-services))) + (service-files + (map shepherd-service-file + (filter (lambda (service) + (memq (shepherd-service-canonical-name service) + to-start)) + target-services)))) + (eval #~(primitive-load #$(upgrade-services-program service-files + to-start + to-unload + to-restart))))))) + + +;;; +;;; Bootloader configuration. +;;; + +(define (install-bootloader-program installer bootloader-package bootcfg + bootcfg-file device target) + "Return an executable store item that, upon being evaluated, will install +BOOTCFG to BOOTCFG-FILE, a target file name, on DEVICE, a file system device, +at TARGET, a mount point, and subsequently run INSTALLER from +BOOTLOADER-PACKAGE." + (program-file + "install-bootloader.scm" + (with-extensions (list guile-gcrypt) + (with-imported-modules (source-module-closure '((gnu build bootloader) + (gnu build install) + (guix store) + (guix utils))) + #~(begin + (use-modules (gnu build bootloader) + (gnu build install) + (guix build utils) + (guix store) + (guix utils) + (ice-9 binary-ports) + (srfi srfi-34) + (srfi srfi-35)) + (let* ((gc-root (string-append #$target %gc-roots-directory "/bootcfg")) + (temp-gc-root (string-append gc-root ".new"))) + (switch-symlinks temp-gc-root gc-root) + (install-boot-config #$bootcfg #$bootcfg-file #$target) + ;; Preserve the previous activation's garbage collector root + ;; until the bootloader installer has run, so that a failure in + ;; the bootloader's installer script doesn't leave the user with + ;; a broken installation. + (when #$installer + (catch #t + (lambda () + (#$installer #$bootloader-package #$device #$target)) + (lambda args + (delete-file temp-gc-root) + (apply throw args)))) + (rename-file temp-gc-root gc-root))))))) + +(define* (install-bootloader eval configuration bootcfg + #:key + (run-installer? #t) + (target "/")) + "Using EVAL, a monadic procedure taking a single G-Expression as an argument, +configure the bootloader on TARGET such that OS will be booted by default and +additional configurations specified by MENU-ENTRIES can be selected." + (let* ((bootloader (bootloader-configuration-bootloader configuration)) + (installer (and run-installer? + (bootloader-installer bootloader))) + (package (bootloader-package bootloader)) + (device (bootloader-configuration-target configuration)) + (bootcfg-file (bootloader-configuration-file bootloader))) + (eval #~(primitive-load #$(install-bootloader-program installer + package + bootcfg + bootcfg-file + device + target))))) diff --git a/tests/services.scm b/tests/services.scm index 44ad0022c6..572fe38164 100644 --- a/tests/services.scm +++ b/tests/services.scm @@ -26,10 +26,6 @@ #:use-module (srfi srfi-64) #:use-module (ice-9 match)) -(define live-service - (@@ (gnu services herd) live-service)) - - (test-begin "services") (test-equal "services, default value" |