1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
| | ;;; 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)
"Return as a monadic value a derivation to build a scheme file that, upon
being evaluated, will create a new generation for SYSTEM-DERIVATION and
execute ACTIVATION-SCRIPT."
(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 %system-profile
(string-append %state-directory "/profiles/system"))
(let* ((number (1+ (generation-number %system-profile)))
(generation (generation-file-name %system-profile number)))
(switch-symlinks generation #$os)
(switch-symlinks %system-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 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."
(gexp->script
"upgrade-shepherd-services.scm"
(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-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 path, on
TARGET, a mount point, and subsequently run INSTALLER-SCRIPT."
(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 "/" %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 ()
(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)))))))
|