[jackhill/guix/guix.git] / guix / scripts / system / reconfigure.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014-2022 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.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 ((guix self) #:select (make-config.scm))
  #: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-34)
  #:use-module (srfi srfi-35)
  #:use-module (srfi srfi-71)
  #: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:

\f
;;;
;;; 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 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)))))

\f
;;;
;;; 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)
                       (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
;; <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.
        ;; 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 ((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))))))))

\f
;;;
;;; 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))))))

\f
;;;
;;; 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 ((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
    ((@ (guix describe) current-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)))
Commit	Line	Data
5c793753	1	;;; GNU Guix --- Functional package management for GNU
e25eca35	2	;;; Copyright © 2014-2022 Ludovic Courtès <ludo@gnu.org>
5c793753 JK	3	;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
	4	;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com>
	5	;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
	6	;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
	7	;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
e8134442	8	;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org>
5c793753 JK	9	;;;
	10	;;; This file is part of GNU Guix.
	11	;;;
	12	;;; GNU Guix is free software; you can redistribute it and/or modify it
	13	;;; under the terms of the GNU General Public License as published by
	14	;;; the Free Software Foundation; either version 3 of the License, or (at
	15	;;; your option) any later version.
	16	;;;
	17	;;; GNU Guix is distributed in the hope that it will be useful, but
	18	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	19	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	20	;;; GNU General Public License for more details.
	21	;;;
	22	;;; You should have received a copy of the GNU General Public License
	23	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	24
	25	(define-module (guix scripts system reconfigure)
	26	#:autoload (gnu packages gnupg) (guile-gcrypt)
	27	#:use-module (gnu bootloader)
	28	#:use-module (gnu services)
	29	#:use-module (gnu services herd)
	30	#:use-module (gnu services shepherd)
	31	#:use-module (gnu system)
	32	#:use-module (guix gexp)
	33	#:use-module (guix modules)
	34	#:use-module (guix monads)
	35	#:use-module (guix store)
a6850f68	36	#:use-module ((guix self) #:select (make-config.scm))
8e31736b LC	37	#:use-module (guix channels)
	38	#:autoload (guix git) (update-cached-checkout)
	39	#:use-module (guix i18n)
	40	#:use-module (guix diagnostics)
5c793753 JK	41	#:use-module (ice-9 match)
5c793753 JK	42	#:use-module (srfi srfi-1)
8e31736b LC	43	#:use-module (srfi srfi-34)
8e31736b LC	44	#:use-module (srfi srfi-35)
d07dd4cc	45	#:use-module (srfi srfi-71)
8e31736b	46	#:use-module ((guix config) #:select (%guix-package-name))
5c793753 JK	47	#:export (switch-system-program
	48	switch-to-system
	49
	50	upgrade-services-program
	51	upgrade-shepherd-services
	52
	53	install-bootloader-program
8e31736b LC	54	install-bootloader
	55
	56	check-forward-update
	57	ensure-forward-reconfigure
	58	warn-about-backward-reconfigure))
5c793753 JK	59
	60	;;; Commentary:
	61	;;;
	62	;;; This module implements the "effectful" parts of system
	63	;;; reconfiguration. Although building a system derivation is a pure
	64	;;; operation, a number of impure operations must be carried out for the
	65	;;; system configuration to be realized -- chiefly, creation of generation
	66	;;; symlinks and invocation of activation scripts.
	67	;;;
	68	;;; Code:
	69
	70	\f
	71	;;;
	72	;;; Profile creation.
	73	;;;
	74
a6850f68 LC	75	(define not-config?
	76	;; Select (guix …) and (gnu …) modules, except (guix config).
	77	(match-lambda
	78	(('guix 'config) #f)
	79	(('guix rest ...) #t)
	80	(('gnu rest ...) #t)
	81	(_ #f)))
	82
5c793753 JK	83	(define* (switch-system-program os #:optional profile)
	84	"Return an executable store item that, upon being evaluated, will create a
	85	new generation of PROFILE pointing to the directory of OS, switch to it
	86	atomically, and run OS's activation script."
	87	(program-file
	88	"switch-to-system.scm"
	89	(with-extensions (list guile-gcrypt)
a6850f68 LC	90	(with-imported-modules `(,@(source-module-closure
	91	'((guix profiles)
	92	(guix utils))
	93	#:select? not-config?)
	94	((guix config) => ,(make-config.scm)))
5c793753 JK	95	#~(begin
	96	(use-modules (guix config)
	97	(guix profiles)
	98	(guix utils))
	99
	100	(define profile
	101	(or #$profile (string-append %state-directory "/profiles/system")))
	102
	103	(let* ((number (1+ (generation-number profile)))
	104	(generation (generation-file-name profile number)))
	105	(switch-symlinks generation #$os)
	106	(switch-symlinks profile generation)
	107	(setenv "GUIX_NEW_SYSTEM" #$os)
	108	(primitive-load #$(operating-system-activation-script os))))))))
	109
	110	(define* (switch-to-system eval os #:optional profile)
	111	"Using EVAL, a monadic procedure taking a single G-Expression as an argument,
	112	create a new generation of PROFILE pointing to the directory of OS, switch to
	113	it atomically, and run OS's activation script."
9fb3ff31 LC	114	(eval #~(parameterize ((current-warning-port (%make-void-port "w")))
9fb3ff31 LC	115	(primitive-load #$(switch-system-program os profile)))))
5c793753 JK	116
	117	\f
	118	;;;
	119	;;; Services.
	120	;;;
	121
	122	(define (running-services eval)
	123	"Using EVAL, a monadic procedure taking a single G-Expression as an argument,
	124	return the <live-service> objects that are currently running on MACHINE."
	125	(define exp
	126	(with-imported-modules '((gnu services herd))
	127	#~(begin
cda046b3 LC	128	(use-modules (gnu services herd)
	129	(ice-9 match))
	130
5c793753 JK	131	(let ((services (current-services)))
5c793753 JK	132	(and services
5c793753 JK	133	(map (lambda (service)
5c793753 JK	134	(list (live-service-provision service)
cda046b3	135	(live-service-requirement service)
7da907f9	136	(live-service-transient? service)
cda046b3 LC	137	(match (live-service-running service)
	138	(#f #f)
	139	(#t #t)
	140	((? number? pid) pid)
	141	(_ #t)))) ;not serializable
5c793753	142	services))))))
cda046b3	143
5c793753 JK	144	(mlet %store-monad ((services (eval exp)))
5c793753 JK	145	(return (map (match-lambda
e25eca35 LC	146	((provision requirement transient? running)
	147	(live-service provision requirement
	148	transient? running)))
5c793753 JK	149	services))))
	150
	151	;; XXX: Currently, this does NOT attempt to restart running services. See
	152	;; <https://issues.guix.info/issue/33508> for details.
	153	(define (upgrade-services-program service-files to-start to-unload to-restart)
	154	"Return an executable store item that, upon being evaluated, will upgrade
	155	the Shepherd (PID 1) by unloading obsolete services and loading new
	156	services. SERVICE-FILES is a list of Shepherd service files to load, and
	157	TO-START, TO-UNLOAD, and TO-RESTART are lists of the Shepherd services'
	158	canonical names (symbols)."
	159	(program-file
	160	"upgrade-shepherd-services.scm"
	161	(with-imported-modules '((gnu services herd))
	162	#~(begin
	163	(use-modules (gnu services herd)
	164	(srfi srfi-1))
	165
	166	;; Load the service files for any new services.
f05f7226 LC	167	;; Silence messages coming from shepherd such as "Evaluating
	168	;; expression ..." since they are unhelpful.
	169	(parameterize ((shepherd-message-port (%make-void-port "w")))
	170	(load-services/safe '#$service-files))
5c793753 JK	171
	172	;; Unload obsolete services and start new services.
	173	(for-each unload-service '#$to-unload)
	174	(for-each start-service '#$to-start)))))
	175
	176	(define* (upgrade-shepherd-services eval os)
	177	"Using EVAL, a monadic procedure taking a single G-Expression as an argument,
	178	upgrade the Shepherd (PID 1) by unloading obsolete services and loading new
	179	services as defined by OS."
	180	(define target-services
ede4a819 LC	181	(shepherd-configuration-services
	182	(service-value
	183	(fold-services (operating-system-services os)
	184	#:target-type shepherd-root-service-type))))
5c793753 JK	185
5c793753 JK	186	(mlet* %store-monad ((live-services (running-services eval)))
d07dd4cc LC	187	(let ((to-unload to-restart
d07dd4cc LC	188	(shepherd-service-upgrade live-services target-services)))
cda046b3	189	(let* ((to-unload (map live-service-canonical-name to-unload))
5c793753	190	(to-restart (map shepherd-service-canonical-name to-restart))
cda046b3 LC	191	(running (map live-service-canonical-name
	192	(filter live-service-running live-services)))
	193	(to-start (lset-difference eqv?
	194	(map shepherd-service-canonical-name
	195	target-services)
	196	running))
1db6f137	197	(service-files (map shepherd-service-file target-services)))
9fb3ff31 LC	198	(eval #~(parameterize ((current-warning-port (%make-void-port "w")))
	199	(primitive-load #$(upgrade-services-program service-files
	200	to-start
	201	to-unload
	202	to-restart))))))))
5c793753 JK	203
	204	\f
	205	;;;
	206	;;; Bootloader configuration.
	207	;;;
	208
a38d861e MO	209	(define (install-bootloader-program installer disk-installer
a38d861e MO	210	bootloader-package bootcfg
2ca982ff	211	bootcfg-file devices target)
5c793753	212	"Return an executable store item that, upon being evaluated, will install
2ca982ff MC	213	BOOTCFG to BOOTCFG-FILE, a target file name, on DEVICES, a list of file system
2ca982ff MC	214	devices, at TARGET, a mount point, and subsequently run INSTALLER from
5c793753 JK	215	BOOTLOADER-PACKAGE."
	216	(program-file
	217	"install-bootloader.scm"
	218	(with-extensions (list guile-gcrypt)
a6850f68 LC	219	(with-imported-modules `(,@(source-module-closure
	220	'((gnu build bootloader)
	221	(gnu build install)
	222	(guix store)
	223	(guix utils))
	224	#:select? not-config?)
	225	((guix config) => ,(make-config.scm)))
5c793753 JK	226	#~(begin
	227	(use-modules (gnu build bootloader)
	228	(gnu build install)
	229	(guix build utils)
	230	(guix store)
	231	(guix utils)
	232	(ice-9 binary-ports)
93add9bf	233	(ice-9 match)
5c793753 JK	234	(srfi srfi-34)
5c793753 JK	235	(srfi srfi-35))
a6850f68	236
5c793753	237	(let* ((gc-root (string-append #$target %gc-roots-directory "/bootcfg"))
5f04e9f9 JK	238	(new-gc-root (string-append gc-root ".new")))
	239	;; #$bootcfg has dependencies.
	240	;; The bootloader magically loads the configuration from
	241	;; (string-append #$target #$bootcfg-file) (for example
	242	;; "/boot/grub/grub.cfg").
	243	;; If we didn't do something special, the garbage collector
	244	;; would remove the dependencies of #$bootcfg.
	245	;; Register #$bootcfg as a GC root.
5c793753 JK	246	;; Preserve the previous activation's garbage collector root
	247	;; until the bootloader installer has run, so that a failure in
	248	;; the bootloader's installer script doesn't leave the user with
	249	;; a broken installation.
5f04e9f9 JK	250	(switch-symlinks new-gc-root #$bootcfg)
5f04e9f9 JK	251	(install-boot-config #$bootcfg #$bootcfg-file #$target)
a38d861e	252	(when (or #$installer #$disk-installer)
5c793753 JK	253	(catch #t
5c793753 JK	254	(lambda ()
a38d861e MO	255	;; The bootloader might not support installation on a
	256	;; mounted directory using the BOOTLOADER-INSTALLER
	257	;; procedure. In that case, fallback to installing the
2ca982ff	258	;; bootloader directly on DEVICES using the
a38d861e MO	259	;; BOOTLOADER-DISK-IMAGE-INSTALLER procedure.
a38d861e MO	260	(if #$installer
2ca982ff MC	261	(for-each (lambda (device)
	262	(#$installer #$bootloader-package device
	263	#$target))
	264	'#$devices)
	265	(for-each (lambda (device)
	266	(#$disk-installer #$bootloader-package
	267	0 device))
	268	'#$devices)))
5c793753	269	(lambda args
5f04e9f9	270	(delete-file new-gc-root)
93add9bf LC	271	(match args
	272	(('%exception exception) ;Guile 3 SRFI-34 or similar
	273	(raise-exception exception))
	274	((key . args)
	275	(apply throw key args))))))
5f04e9f9 JK	276	;; We are sure that the installation of the bootloader
	277	;; succeeded, so we can replace the old GC root by the new
	278	;; GC root now.
	279	(rename-file new-gc-root gc-root)))))))
5c793753 JK	280
	281	(define* (install-bootloader eval configuration bootcfg
	282	#:key
	283	(run-installer? #t)
	284	(target "/"))
	285	"Using EVAL, a monadic procedure taking a single G-Expression as an argument,
	286	configure the bootloader on TARGET such that OS will be booted by default and
	287	additional configurations specified by MENU-ENTRIES can be selected."
	288	(let* ((bootloader (bootloader-configuration-bootloader configuration))
	289	(installer (and run-installer?
	290	(bootloader-installer bootloader)))
a38d861e MO	291	(disk-installer (and run-installer?
a38d861e MO	292	(bootloader-disk-image-installer bootloader)))
5c793753	293	(package (bootloader-package bootloader))
2ca982ff	294	(devices (bootloader-configuration-targets configuration))
5c793753	295	(bootcfg-file (bootloader-configuration-file bootloader)))
9fb3ff31 LC	296	(eval #~(parameterize ((current-warning-port (%make-void-port "w")))
9fb3ff31 LC	297	(primitive-load #$(install-bootloader-program installer
a38d861e	298	disk-installer
9fb3ff31 LC	299	package
	300	bootcfg
	301	bootcfg-file
2ca982ff	302	devices
9fb3ff31	303	target))))))
8e31736b LC	304
	305	\f
	306	;;;
	307	;;; Downgrade detection.
	308	;;;
	309
	310	(define (ensure-forward-reconfigure channel start commit relation)
	311	"Raise an error if RELATION is not 'ancestor, meaning that START is not an
	312	ancestor of COMMIT, unless CHANNEL specifies a commit."
	313	(match relation
	314	('ancestor #t)
	315	('self #t)
	316	(_
	317	(raise (make-compound-condition
7916201c	318	(formatted-message (G_ "\
8e31736b	319	aborting reconfiguration because commit ~a of channel '~a' is not a descendant of ~a")
7916201c LC	320	commit (channel-name channel)
	321	start)
	322	(condition
8e31736b LC	323	(&fix-hint
	324	(hint (G_ "Use @option{--allow-downgrades} to force
	325	this downgrade.")))))))))
	326
	327	(define (warn-about-backward-reconfigure channel start commit relation)
	328	"Warn about non-forward updates of CHANNEL from START to COMMIT, without
	329	aborting."
	330	(match relation
	331	((or 'ancestor 'self)
	332	#t)
	333	('descendant
	334	(warning (G_ "rolling back channel '~a' from ~a to ~a~%")
	335	(channel-name channel) start commit))
	336	('unrelated
	337	(warning (G_ "moving channel '~a' from ~a to unrelated commit ~a~%")
	338	(channel-name channel) start commit))))
	339
	340	(define (channel-relations old new)
	341	"Return a list of channel/relation pairs, where each relation is a symbol as
	342	returned by 'commit-relation' denoting how commits of channels in OLD relate
	343	to commits of channels in NEW."
	344	(filter-map (lambda (old)
	345	(let ((new (find (lambda (channel)
	346	(eq? (channel-name channel)
	347	(channel-name old)))
	348	new)))
	349	(and new
d07dd4cc LC	350	(let ((checkout commit relation
	351	(update-cached-checkout
	352	(channel-url new)
	353	#:ref `(commit . ,(channel-commit new))
	354	#:starting-commit (channel-commit old)
	355	#:check-out? #f)))
8e31736b LC	356	(list new
	357	(channel-commit old) (channel-commit new)
	358	relation)))))
	359	old))
	360
	361	(define* (check-forward-update #:optional
a396dd01 LC	362	(validate-reconfigure
	363	ensure-forward-reconfigure)
	364	#:key
	365	(current-channels
	366	(system-provenance "/run/current-system")))
8e31736b	367	"Call VALIDATE-RECONFIGURE passing it, for each channel, the channel, the
a396dd01 LC	368	currently-deployed commit (from CURRENT-CHANNELS, which is as returned by
	369	'guix system describe' by default) and the target commit (as returned by 'guix
	370	describe')."
8e31736b	371	(define new
270e1b9e	372	((@ (guix describe) current-channels)))
8e31736b	373
a396dd01 LC	374	(when (null? current-channels)
a396dd01 LC	375	(warning (G_ "cannot determine provenance for current system~%")))
8e31736b LC	376	(when (and (null? new) (not (getenv "GUIX_UNINSTALLED")))
	377	(warning (G_ "cannot determine provenance of ~a~%") %guix-package-name))
	378
	379	(for-each (match-lambda
	380	((channel old new relation)
	381	(validate-reconfigure channel old new relation)))
a396dd01	382	(channel-relations current-channels new)))