mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 05:18:07 -05:00
guix system: Add 'reconfigure' module.
* guix/scripts/system/reconfigure.scm: New file. * Makefile.am (MODULES): Add it. * guix/scripts/system.scm (bootloader-installer-script): Export variable. * gnu/machine/ssh.scm (switch-to-system, upgrade-shepherd-services) (install-bootloader): Delete variable. * gnu/machine/ssh.scm (deploy-managed-host): Rewrite procedure. * gnu/services/herd.scm (live-service): Export variable. * gnu/services/herd.scm (live-service-canonical-name): New variable. * tests/services.scm (live-service): Delete variable. Signed-off-by: Ludovic Courtès <ludo@gnu.org>
This commit is contained in:
parent
20269b6e08
commit
5c793753b3
5 changed files with 256 additions and 181 deletions
|
@ -249,6 +249,7 @@ MODULES = \
|
||||||
guix/scripts/describe.scm \
|
guix/scripts/describe.scm \
|
||||||
guix/scripts/system.scm \
|
guix/scripts/system.scm \
|
||||||
guix/scripts/system/search.scm \
|
guix/scripts/system/search.scm \
|
||||||
|
guix/scripts/system/reconfigure.scm \
|
||||||
guix/scripts/lint.scm \
|
guix/scripts/lint.scm \
|
||||||
guix/scripts/challenge.scm \
|
guix/scripts/challenge.scm \
|
||||||
guix/scripts/import/crate.scm \
|
guix/scripts/import/crate.scm \
|
||||||
|
|
|
@ -17,23 +17,21 @@
|
||||||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
(define-module (gnu machine ssh)
|
(define-module (gnu machine ssh)
|
||||||
#:use-module (gnu bootloader)
|
|
||||||
#:use-module (gnu machine)
|
#:use-module (gnu machine)
|
||||||
#:autoload (gnu packages gnupg) (guile-gcrypt)
|
#:autoload (gnu packages gnupg) (guile-gcrypt)
|
||||||
#:use-module (gnu services)
|
|
||||||
#:use-module (gnu services shepherd)
|
|
||||||
#:use-module (gnu system)
|
#:use-module (gnu system)
|
||||||
#:use-module (guix derivations)
|
|
||||||
#:use-module (guix gexp)
|
#:use-module (guix gexp)
|
||||||
#:use-module (guix i18n)
|
#:use-module (guix i18n)
|
||||||
#:use-module (guix modules)
|
#:use-module (guix modules)
|
||||||
#:use-module (guix monads)
|
#:use-module (guix monads)
|
||||||
#:use-module (guix records)
|
#:use-module (guix records)
|
||||||
#:use-module (guix remote)
|
#:use-module (guix remote)
|
||||||
|
#:use-module (guix scripts system reconfigure)
|
||||||
#:use-module (guix ssh)
|
#:use-module (guix ssh)
|
||||||
#:use-module (guix store)
|
#:use-module (guix store)
|
||||||
#:use-module (ice-9 match)
|
#:use-module (ice-9 match)
|
||||||
#:use-module (srfi srfi-19)
|
#:use-module (srfi srfi-19)
|
||||||
|
#:use-module (srfi srfi-26)
|
||||||
#:use-module (srfi srfi-35)
|
#:use-module (srfi srfi-35)
|
||||||
#:export (managed-host-environment-type
|
#:export (managed-host-environment-type
|
||||||
|
|
||||||
|
@ -105,118 +103,6 @@ (define (managed-host-remote-eval machine exp)
|
||||||
;;; System deployment.
|
;;; 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)
|
(define (machine-boot-parameters machine)
|
||||||
"Monadic procedure returning a list of 'boot-parameters' for the generations
|
"Monadic procedure returning a list of 'boot-parameters' for the generations
|
||||||
of MACHINE's system profile, ordered from most recent to oldest."
|
of MACHINE's system profile, ordered from most recent to oldest."
|
||||||
|
@ -275,71 +161,20 @@ (define (read-file path)
|
||||||
(boot-parameters-kernel-arguments params))))))))
|
(boot-parameters-kernel-arguments params))))))))
|
||||||
generations))))
|
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)
|
(define (deploy-managed-host machine)
|
||||||
"Internal implementation of 'deploy-machine' for MACHINE instances with an
|
"Internal implementation of 'deploy-machine' for MACHINE instances with an
|
||||||
environment type of 'managed-host."
|
environment type of 'managed-host."
|
||||||
(maybe-raise-unsupported-configuration-error machine)
|
(maybe-raise-unsupported-configuration-error machine)
|
||||||
(mbegin %store-monad
|
(mlet %store-monad ((boot-parameters (machine-boot-parameters machine)))
|
||||||
(switch-to-system machine)
|
(let* ((os (machine-system machine))
|
||||||
(upgrade-shepherd-services machine)
|
(eval (cut machine-remote-eval machine <>))
|
||||||
(install-bootloader 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)))))
|
||||||
|
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
|
|
|
@ -40,10 +40,12 @@ (define-module (gnu services herd)
|
||||||
unknown-shepherd-error?
|
unknown-shepherd-error?
|
||||||
unknown-shepherd-error-sexp
|
unknown-shepherd-error-sexp
|
||||||
|
|
||||||
|
live-service
|
||||||
live-service?
|
live-service?
|
||||||
live-service-provision
|
live-service-provision
|
||||||
live-service-requirement
|
live-service-requirement
|
||||||
live-service-running
|
live-service-running
|
||||||
|
live-service-canonical-name
|
||||||
|
|
||||||
with-shepherd-action
|
with-shepherd-action
|
||||||
current-services
|
current-services
|
||||||
|
@ -192,6 +194,10 @@ (define-record-type <live-service>
|
||||||
(requirement live-service-requirement) ;list of symbols
|
(requirement live-service-requirement) ;list of symbols
|
||||||
(running live-service-running)) ;#f | object
|
(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)
|
(define (current-services)
|
||||||
"Return the list of currently defined Shepherd services, represented as
|
"Return the list of currently defined Shepherd services, represented as
|
||||||
<live-service> objects. Return #f if the list of services could not be
|
<live-service> objects. Return #f if the list of services could not be
|
||||||
|
|
237
guix/scripts/system/reconfigure.scm
Normal file
237
guix/scripts/system/reconfigure.scm
Normal file
|
@ -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)))))
|
|
@ -26,10 +26,6 @@ (define-module (test-services)
|
||||||
#:use-module (srfi srfi-64)
|
#:use-module (srfi srfi-64)
|
||||||
#:use-module (ice-9 match))
|
#:use-module (ice-9 match))
|
||||||
|
|
||||||
(define live-service
|
|
||||||
(@@ (gnu services herd) live-service))
|
|
||||||
|
|
||||||
|
|
||||||
(test-begin "services")
|
(test-begin "services")
|
||||||
|
|
||||||
(test-equal "services, default value"
|
(test-equal "services, default value"
|
||||||
|
|
Loading…
Reference in a new issue