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
159
160
161
162
163
164
165
166
167
168
169
170
| | ;;; 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 #:optional profile)
"Return as a monadic value a derivation to build a scheme file 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,
returning any textual output produced by the activation script as a string."
(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 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)
(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 upgrade the Shepherd (PID 1) by unloading obsolete
services and loading new services. TARGET-SERVICES is a list
of (shepherd-service-canonical-name, shepherd-service-file) pairs used for
determining which services are obsolete, as well as which are new."
(gexp->script
"upgrade-shepherd-services.scm"
(with-imported-modules '((gnu services herd))
#~(begin
(use-modules (gnu services herd)
(srfi srfi-1))
(define (call-with-shepherd-error-handling proc)
(lambda (service)
(catch 'system-error
(lambda ()
(proc service)
#f)
(lambda (key proc format-string format-args errno . rest)
(apply format #f format-string format-args)))))
(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))
;; Load the service files for any new services.
(load-services/safe (map second to-start))
;; Unload obsolete services and start new services.
(filter string?
(append (map (call-with-shepherd-error-handling unload-service)
to-unload)
(map (call-with-shepherd-error-handling 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 file name, on
TARGET, a mount point, and subsequently run INSTALLER-SCRIPT, returning any
textual output produced by the installer script as a string."
(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 #$target %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 ()
(when #$installer-script
(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)))))))
|