;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014-2022 Ludovic Courtès ;;; Copyright © 2016 Alex Kost ;;; Copyright © 2016, 2017, 2018 Chris Marusich ;;; Copyright © 2017 Mathieu Othacehe ;;; Copyright © 2018 Ricardo Wurmus ;;; Copyright © 2019 Christopher Baines ;;; Copyright © 2019 Jakob L. Kreuze ;;; Copyright © 2022 Arun Isaac ;;; ;;; 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 . (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 ((guix self) #:select (make-config.scm)) #:autoload (guix describe) (current-profile) #:use-module (guix channels) #:autoload (guix git) (update-cached-checkout) #:use-module (guix i18n) #:use-module (guix diagnostics) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module ((guix config) #:select (%guix-package-name)) #:export (switch-system-program switch-to-system upgrade-services-program upgrade-shepherd-services install-bootloader-program install-bootloader check-forward-update ensure-forward-reconfigure warn-about-backward-reconfigure)) ;;; 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 not-config? ;; Select (guix …) and (gnu …) modules, except (guix config). (match-lambda (('guix 'config) #f) (('guix rest ...) #t) (('gnu rest ...) #t) (_ #f))) (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 profiles) (guix utils)) #:select? not-config?) ((guix config) => ,(make-config.scm))) #~(begin (use-modules (guix build utils) (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 #~(parameterize ((current-warning-port (%make-void-port "w"))) (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 objects that are currently running on MACHINE." (define exp (with-imported-modules '((gnu services herd)) #~(begin (use-modules (gnu services herd) (ice-9 match)) (let ((services (current-services))) (and services (map (lambda (service) (list (live-service-provision service) (live-service-requirement service) (live-service-transient? service) (match (live-service-running service) (#f #f) (#t #t) ((? number? pid) pid) (_ #t)))) ;not serializable services)))))) (mlet %store-monad ((services (eval exp))) (return (map (match-lambda ((provision requirement transient? running) (live-service provision requirement transient? running))) services)))) ;; XXX: Currently, this does NOT attempt to restart running services. See ;; 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. ;; Silence messages coming from shepherd such as "Evaluating ;; expression ..." since they are unhelpful. (parameterize ((shepherd-message-port (%make-void-port "w"))) (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 (shepherd-configuration-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)) (running (map live-service-canonical-name (filter live-service-running live-services))) (to-start (lset-difference eqv? (map shepherd-service-canonical-name target-services) running)) (service-files (map shepherd-service-file target-services))) (eval #~(parameterize ((current-warning-port (%make-void-port "w"))) (primitive-load #$(upgrade-services-program service-files to-start to-unload to-restart)))))))) ;;; ;;; Bootloader configuration. ;;; (define (install-bootloader-program installer disk-installer bootloader-package bootcfg bootcfg-file devices target) "Return an executable store item that, upon being evaluated, will install BOOTCFG to BOOTCFG-FILE, a target file name, on DEVICES, a list of file system devices, 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)) #:select? not-config?) ((guix config) => ,(make-config.scm))) #~(begin (use-modules (gnu build bootloader) (gnu build install) (guix build utils) (guix store) (guix utils) (ice-9 binary-ports) (ice-9 match) (srfi srfi-34) (srfi srfi-35)) (let* ((gc-root (string-append #$target %gc-roots-directory "/bootcfg")) (new-gc-root (string-append gc-root ".new"))) ;; #$bootcfg has dependencies. ;; The bootloader magically loads the configuration from ;; (string-append #$target #$bootcfg-file) (for example ;; "/boot/grub/grub.cfg"). ;; If we didn't do something special, the garbage collector ;; would remove the dependencies of #$bootcfg. ;; Register #$bootcfg as a GC root. ;; 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. (switch-symlinks new-gc-root #$bootcfg) (install-boot-config #$bootcfg #$bootcfg-file #$target) (when (or #$installer #$disk-installer) (catch #t (lambda () ;; The bootloader might not support installation on a ;; mounted directory using the BOOTLOADER-INSTALLER ;; procedure. In that case, fallback to installing the ;; bootloader directly on DEVICES using the ;; BOOTLOADER-DISK-IMAGE-INSTALLER procedure. (if #$installer (for-each (lambda (device) (#$installer #$bootloader-package device #$target)) '#$devices) (for-each (lambda (device) (#$disk-installer #$bootloader-package 0 device)) '#$devices))) (lambda args (delete-file new-gc-root) (match args (('%exception exception) ;Guile 3 SRFI-34 or similar (raise-exception exception)) ((key . args) (apply throw key args)))))) ;; We are sure that the installation of the bootloader ;; succeeded, so we can replace the old GC root by the new ;; GC root now. (rename-file new-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))) (disk-installer (and run-installer? (bootloader-disk-image-installer bootloader))) (package (bootloader-package bootloader)) (devices (bootloader-configuration-targets configuration)) (bootcfg-file (bootloader-configuration-file bootloader))) (eval #~(parameterize ((current-warning-port (%make-void-port "w"))) (primitive-load #$(install-bootloader-program installer disk-installer package bootcfg bootcfg-file devices target)))))) ;;; ;;; Downgrade detection. ;;; (define (ensure-forward-reconfigure channel start commit relation) "Raise an error if RELATION is not 'ancestor, meaning that START is not an ancestor of COMMIT, unless CHANNEL specifies a commit." (match relation ('ancestor #t) ('self #t) (_ (raise (make-compound-condition (formatted-message (G_ "\ aborting reconfiguration because commit ~a of channel '~a' is not a descendant of ~a") commit (channel-name channel) start) (condition (&fix-hint (hint (G_ "Use @option{--allow-downgrades} to force this downgrade."))))))))) (define (warn-about-backward-reconfigure channel start commit relation) "Warn about non-forward updates of CHANNEL from START to COMMIT, without aborting." (match relation ((or 'ancestor 'self) #t) ('descendant (warning (G_ "rolling back channel '~a' from ~a to ~a~%") (channel-name channel) start commit)) ('unrelated (warning (G_ "moving channel '~a' from ~a to unrelated commit ~a~%") (channel-name channel) start commit)))) (define (channel-relations old new) "Return a list of channel/relation pairs, where each relation is a symbol as returned by 'commit-relation' denoting how commits of channels in OLD relate to commits of channels in NEW." (filter-map (lambda (old) (let ((new (find (lambda (channel) (eq? (channel-name channel) (channel-name old))) new))) (and new (let-values (((checkout commit relation) (update-cached-checkout (channel-url new) #:ref `(commit . ,(channel-commit new)) #:starting-commit (channel-commit old) #:check-out? #f))) (list new (channel-commit old) (channel-commit new) relation))))) old)) (define* (check-forward-update #:optional (validate-reconfigure ensure-forward-reconfigure) #:key (current-channels (system-provenance "/run/current-system"))) "Call VALIDATE-RECONFIGURE passing it, for each channel, the channel, the currently-deployed commit (from CURRENT-CHANNELS, which is as returned by 'guix system describe' by default) and the target commit (as returned by 'guix describe')." (define new (or (and=> (current-profile) profile-channels) '())) (when (null? current-channels) (warning (G_ "cannot determine provenance for current system~%"))) (when (and (null? new) (not (getenv "GUIX_UNINSTALLED"))) (warning (G_ "cannot determine provenance of ~a~%") %guix-package-name)) (for-each (match-lambda ((channel old new relation) (validate-reconfigure channel old new relation))) (channel-relations current-channels new)))