@@ -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 \
@@ -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,157 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; 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 (guix gexp)
+ #:use-module (guix modules)
+ #:export (switch-to-system
+ upgrade-shepherd-services
+ 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:
+
+(define (switch-to-system system-derivation activation-script)
+ "Return a G-Expression that, upon being evaluated, will create a new
+generation for SYSTEM-DERIVATION and execute ACTIVATION-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 #$system-derivation)
+ (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 #$activation-script))))))))
+
+;; XXX: Currently, this does NOT attempt to restart running services. See
+;; <https://issues.guix.info/issue/33508> for details.
+(define (upgrade-shepherd-services target-services)
+ "Return a G-Expression that, upon being evaluated, will use TARGET-SERVICES,
+a list of (shepherd-service-canonical-name, shepherd-service-file) pairs to
+determine which services are obsolete and need to be unloaded, as well as
+which services are new and need to be started."
+ (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)))))
+
+(define (install-bootloader installer-script bootcfg bootcfg-file target)
+ "Return a G-Expression that, upon being evaluated, will install BOOTCFG to
+BOOTCFG-FILE, a target path, on TARGET, a mount point, and subsequently run
+INSTALLER-SCRIPT."
+ (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 #$target)
+ ;; 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-script)))))
+ (delete-file temp-gc-root)
+ (error "failed to install bootloader"))
+
+ (rename-file temp-gc-root gc-root))))))