@@ -245,6 +245,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 \
@@ -21,6 +21,7 @@
#:use-module (gnu machine)
#:autoload (gnu packages gnupg) (guile-gcrypt)
#:use-module (gnu services)
+ #:use-module (gnu services herd)
#:use-module (gnu services shepherd)
#:use-module (gnu system)
#:use-module (guix derivations)
@@ -30,10 +31,15 @@
#:use-module (guix monads)
#:use-module (guix records)
#:use-module (guix remote)
+ #:use-module (guix scripts system)
+ #:use-module (guix scripts system reconfigure)
#:use-module (guix ssh)
#:use-module (guix store)
#:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
#:use-module (srfi srfi-19)
+ #:use-module (srfi srfi-26)
#:use-module (srfi srfi-35)
#:export (managed-host-environment-type
@@ -105,118 +111,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 +169,99 @@ 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 (machine-current-services machine)
+ "Return the <live-service> objects that are currently running on MACHINE."
+ (define remote-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 (machine-remote-eval machine remote-exp)))
+ (return (map (match-lambda
+ ((provision requirement)
+ (live-service provision requirement #f)))
+ services))))
(define (deploy-managed-host machine)
"Internal implementation of 'deploy-machine' for MACHINE instances with an
environment type of 'managed-host."
+ (define target-services
+ (service-value
+ (fold-services (operating-system-services (machine-system machine))
+ #:target-type shepherd-root-service-type)))
+
+ (define (run-switch-to-system machine)
+ "Monadic procedure serializing the items in MACHINE necessary to build a
+G-Expression with 'switch-to-system'."
+ (machine-remote-eval machine #~(primitive-load
+ #$(switch-system-program
+ (machine-system machine)))))
+
+ (define (run-upgrade-shepherd-services machine)
+ "Monadic procedure serializing the items in MACHINE necessary to build a
+G-Expression with 'upgrade-shepherd-services'."
+ (mlet* %store-monad ((live-services (machine-current-services machine)))
+ (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))))
+ (machine-remote-eval machine
+ #~(primitive-load
+ #$(upgrade-services-program service-files
+ to-start
+ to-unload
+ to-restart)))))))
+
+ (define (run-install-bootloader machine)
+ "Monadic procedure serializing the items in MACHINE necessary to build a
+G-Expression with 'install-bootloader'."
+ (mlet %store-monad ((boot-parameters (machine-boot-parameters machine)))
+ (let* ((os (machine-system machine))
+ (bootloader ((compose bootloader-configuration-bootloader
+ operating-system-bootloader)
+ os))
+ (target (bootloader-configuration-target
+ (operating-system-bootloader os)))
+ (installer (bootloader-installer-script
+ (bootloader-installer bootloader)
+ (bootloader-package 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
+ #~(primitive-load
+ #$(install-bootloader-program installer
+ bootcfg
+ bootcfg-file
+ "/"))))))
+
(maybe-raise-unsupported-configuration-error machine)
- (mbegin %store-monad
- (switch-to-system machine)
- (upgrade-shepherd-services machine)
- (install-bootloader machine)))
+ (mapm %store-monad (cut <> machine)
+ (list run-switch-to-system
+ run-install-bootloader
+ run-upgrade-shepherd-services)))
;;;
@@ -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
@@ -70,6 +70,7 @@
#:use-module (ice-9 match)
#:use-module (rnrs bytevectors)
#:export (guix-system
+ bootloader-installer-script
read-operating-system))
new file mode 100644
@@ -0,0 +1,170 @@
+;;; 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 system)
+ #:use-module (guix gexp)
+ #:use-module (guix modules)
+ #:export (switch-system-program
+ upgrade-services-program
+ install-bootloader-program))
+
+;;; 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:
+
+(define* (switch-system-program os #:optional profile)
+ "Return as a monadic value a derivation to build a scheme file 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,
+returning any textual output produced by the activation script as a string."
+ (gexp->script
+ "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)
+ (with-output-to-string
+ (lambda ()
+ (primitive-load
+ #$(operating-system-activation-script os))))))))))
+
+;; XXX: Currently, this does NOT attempt to restart running services. See
+;; <https://issues.guix.info/issue/33508> for details.
+(define (upgrade-services-program target-services)
+ "Return as a monadic value a derivation to build a scheme file that, upon
+being evaluated, will upgrade the Shepherd (PID 1) by unloading obsolete
+services and loading new services. TARGET-SERVICES is a list
+of (shepherd-service-canonical-name, shepherd-service-file) pairs used for
+determining which services are obsolete, as well as which are new."
+ (gexp->script
+ "upgrade-shepherd-services.scm"
+ (with-imported-modules '((gnu services herd))
+ #~(begin
+ (use-modules (gnu services herd)
+ (srfi srfi-1))
+
+ (define (call-with-shepherd-error-handling proc)
+ (lambda (service)
+ (catch 'system-error
+ (lambda ()
+ (proc service)
+ #f)
+ (lambda (key proc format-string format-args errno . rest)
+ (apply format #f format-string format-args)))))
+
+ (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))
+
+ ;; Load the service files for any new services.
+ (load-services/safe (map second to-start))
+
+ ;; Unload obsolete services and start new services.
+ (filter string?
+ (append (map (call-with-shepherd-error-handling unload-service)
+ to-unload)
+ (map (call-with-shepherd-error-handling start-service)
+ (map first to-start))))))))
+
+(define (install-bootloader-program installer-script bootcfg bootcfg-file target)
+ "Return as a monadic value a derivation to build a scheme file that, upon
+being evaluated, will install BOOTCFG to BOOTCFG-FILE, a target file name, on
+TARGET, a mount point, and subsequently run INSTALLER-SCRIPT, returning any
+textual output produced by the installer script as a string."
+ (gexp->script
+ "install-bootloader.scm"
+ (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 #$target %gc-roots-directory "/bootcfg"))
+ (temp-gc-root (string-append gc-root ".new")))
+
+ (switch-symlinks temp-gc-root gc-root)
+
+ (let ((installer-result
+ (false-if-exception
+ (begin
+ (install-boot-config #$bootcfg #$bootcfg-file #$target)
+ (with-output-to-string
+ (lambda ()
+ (when #$installer-script
+ (primitive-load #$installer-script))))))))
+ (unless installer-result
+ (delete-file temp-gc-root)
+ (error "failed to install bootloader"))
+ (rename-file temp-gc-root gc-root)
+ installer-result)))))))
@@ -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"