summaryrefslogtreecommitdiff
path: root/guix/scripts/system/reconfigure.scm
blob: a2570839a80273dddd83ff4912f358b04c68f496 (about) (plain)
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
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 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))
  #: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 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 <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.
        ;; 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
    (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 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 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))
                                 #: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 #$installer
               (catch #t
                 (lambda ()
                   (#$installer #$bootloader-package #$device #$target))
                 (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)))
         (package (bootloader-package bootloader))
         (device (bootloader-configuration-target configuration))
         (bootcfg-file (bootloader-configuration-file bootloader)))
    (eval #~(parameterize ((current-warning-port (%make-void-port "w")))
              (primitive-load #$(install-bootloader-program installer
                                                            package
                                                            bootcfg
                                                            bootcfg-file
                                                            device
                                                            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
             (condition
              (&message (message
                         (format #f (G_ "\
aborting reconfiguration because commit ~a of channel '~a' is not a descendant of ~a")
                                 commit (channel-name channel)
                                 start)))
              (&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))
  "Call VALIDATE-RECONFIGURE passing it, for each channel, the channel, the
currently-deployed commit (as returned by 'guix system describe') and the
target commit (as returned by 'guix describe')."
  ;; TODO: Make that functionality available to 'guix deploy'.
  (define new
    (or (and=> (current-profile) profile-channels)
        '()))

  (define old
    (system-provenance "/run/current-system"))

  (when (null? old)
    (warning (G_ "cannot determine provenance for /run/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 old new)))