unofficial mirror of guix-patches@gnu.org 
 help / color / mirror / code / Atom feed
blob 9b92198076bc862f47c1739abb28ce062969afd5 16407 bytes (raw)
name: guix/scripts/system/reconfigure.scm 	 # note: path name is non-authoritative(*)

  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
363
364
365
366
367
368
369
 
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014-2022, 2024 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>
;;; Copyright © 2022 Arun Isaac <arunisaac@systemreboot.net>
;;; Copyright © 2024 Lilah Tascheter <lilah@lunabee.space>
;;;
;;; 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 build utils)
                        (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" generation)
             (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))
           (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
                                             (filter shepherd-service-auto-start?
                                                     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 configs offset chosen-alt old-alts locale
                                    store-crypto-devices store-directory-prefix)
  "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"
    ;; three sources of boot entries: bootloader-configuration-menu-entries,
    ;; current-boot-alternative, and old-boot-alternatives.
    (let ((args (list #:current-boot-alternative chosen-alt
                      #:old-boot-alternatives old-alts
                      #:locale locale
                      #:store-directory-prefix store-directory-prefix
                      #:store-crypto-devices store-crypto-devices)))
      (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))
              ;; bootloader-installer is passed an additional #:target argument
              ;; denoting the specific target currently being installed to.
              ;; bootloaders should determine when to fully reinstall themselves.
              #$(bootloader-configurations->gexp configs args
                                                 #:root-offset offset)))))))

(define* (install-bootloader eval configs alts
                             #:key
                             store-crypto-devices store-directory-prefix
                             (root-offset "/") dry-run? locale)
  "Using EVAL, a monadic procedure taking a single G-Expression as an argument,
configure the bootloader with bootloader-configuration CONFIG such that
ALTS may be selected, with the first element being the default.  If QUICK? only
the bootloader config is reinstalled.  Returns the config installer drv."
  (mlet* %store-monad
         ((program (lower-object
                     (install-bootloader-program configs root-offset
                       (car alts) (cdr alts) locale
                       store-crypto-devices store-directory-prefix))))
    (mbegin %store-monad
      (eval
        (with-imported-modules `(,@(source-module-closure '((guix build utils)
                                                            (guix store))
                                                          #:select? not-config?)
                                 ((guix config) => ,(make-config.scm)))
          #~(begin
              (use-modules (guix build utils) (guix store))
              (parameterize ((current-warning-port (%make-void-port "w")))
                (let* ((gc-root (string-append
                                  #$root-offset %gc-roots-directory "/bootcfg"))
                       (new-gc-root (string-append gc-root ".new")))
                  ;; since the installers are gexps directly included, we add
                  ;; the installer runner as a gc root.  this should make sure
                  ;; no bootloader files get gc'd.  only remove the old one on
                  ;; success.
                  ;; XXX: is this still necessary?
                  (switch-symlinks new-gc-root #$program)
                  (dynamic-wind (const #t)
                    (lambda ()
                      (unless #$dry-run? (primitive-load #$program))
                      (rename-file new-gc-root gc-root))
                    (lambda () ; delete new root if failed
                      (when (file-exists? new-gc-root)
                        (delete-file new-gc-root)))))))))
      (return program))))

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

debug log:

solving 9b92198076 ...
found 9b92198076 in https://yhetil.org/guix-patches/dca9304c33b9a7a767a22582aa63b504a8dc034b.1727201267.git.herman@rimm.ee/
found 604ba08fee in https://git.savannah.gnu.org/cgit/guix.git
preparing index
index prepared:
100644 604ba08feee8b1bbdc706f7cab13c20d0796eab0	guix/scripts/system/reconfigure.scm

applying [1/1] https://yhetil.org/guix-patches/dca9304c33b9a7a767a22582aa63b504a8dc034b.1727201267.git.herman@rimm.ee/
diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm
index 604ba08fee..9b92198076 100644

Checking patch guix/scripts/system/reconfigure.scm...
Applied patch guix/scripts/system/reconfigure.scm cleanly.

index at:
100644 9b92198076bc862f47c1739abb28ce062969afd5	guix/scripts/system/reconfigure.scm

(*) Git path names are given by the tree(s) the blob belongs to.
    Blobs themselves have no identifier aside from the hash of its contents.^

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/guix.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).