guix/scripts/system/reconfigure.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
   4 ;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com>
   5 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
   6 ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
   7 ;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
   8 ;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org>
   9 ;;;
  10 ;;; This file is part of GNU Guix.
  11 ;;;
  12 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  13 ;;; under the terms of the GNU General Public License as published by
  14 ;;; the Free Software Foundation; either version 3 of the License, or (at
  15 ;;; your option) any later version.
  16 ;;;
  17 ;;; GNU Guix is distributed in the hope that it will be useful, but
  18 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;;; GNU General Public License for more details.
  21 ;;;
  22 ;;; You should have received a copy of the GNU General Public License
  23 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 (define-module (guix scripts system reconfigure)
  26   #:autoload   (gnu packages gnupg) (guile-gcrypt)
  27   #:use-module (gnu bootloader)
  28   #:use-module (gnu services)
  29   #:use-module (gnu services herd)
  30   #:use-module (gnu services shepherd)
  31   #:use-module (gnu system)
  32   #:use-module (guix gexp)
  33   #:use-module (guix modules)
  34   #:use-module (guix monads)
  35   #:use-module (guix store)
  36   #:use-module ((guix self) #:select (make-config.scm))
  37   #:autoload   (guix describe) (current-profile)
  38   #:use-module (guix channels)
  39   #:autoload   (guix git) (update-cached-checkout)
  40   #:use-module (guix i18n)
  41   #:use-module (guix diagnostics)
  42   #:use-module (ice-9 match)
  43   #:use-module (srfi srfi-1)
  44   #:use-module (srfi srfi-11)
  45   #:use-module (srfi srfi-34)
  46   #:use-module (srfi srfi-35)
  47   #:use-module ((guix config) #:select (%guix-package-name))
  48   #:export (switch-system-program
  49             switch-to-system
  50
  51             upgrade-services-program
  52             upgrade-shepherd-services
  53
  54             install-bootloader-program
  55             install-bootloader
  56
  57             check-forward-update
  58             ensure-forward-reconfigure
  59             warn-about-backward-reconfigure))
  60
  61 ;;; Commentary:
  62 ;;;
  63 ;;; This module implements the "effectful" parts of system
  64 ;;; reconfiguration. Although building a system derivation is a pure
  65 ;;; operation, a number of impure operations must be carried out for the
  66 ;;; system configuration to be realized -- chiefly, creation of generation
  67 ;;; symlinks and invocation of activation scripts.
  68 ;;;
  69 ;;; Code:
  70
  71 \f
  72 ;;;
  73 ;;; Profile creation.
  74 ;;;
  75
  76 (define not-config?
  77   ;; Select (guix …) and (gnu …) modules, except (guix config).
  78   (match-lambda
  79     (('guix 'config) #f)
  80     (('guix rest ...) #t)
  81     (('gnu rest ...) #t)
  82     (_ #f)))
  83
  84 (define* (switch-system-program os #:optional profile)
  85   "Return an executable store item that, upon being evaluated, will create a
  86 new generation of PROFILE pointing to the directory of OS, switch to it
  87 atomically, and run OS's activation script."
  88   (program-file
  89    "switch-to-system.scm"
  90    (with-extensions (list guile-gcrypt)
  91      (with-imported-modules `(,@(source-module-closure
  92                                  '((guix profiles)
  93                                    (guix utils))
  94                                  #:select? not-config?)
  95                               ((guix config) => ,(make-config.scm)))
  96        #~(begin
  97            (use-modules (guix config)
  98                         (guix profiles)
  99                         (guix utils))
 100
 101            (define profile
 102              (or #$profile (string-append %state-directory "/profiles/system")))
 103
 104            (let* ((number (1+ (generation-number profile)))
 105                   (generation (generation-file-name profile number)))
 106              (switch-symlinks generation #$os)
 107              (switch-symlinks profile generation)
 108              (setenv "GUIX_NEW_SYSTEM" #$os)
 109              (primitive-load #$(operating-system-activation-script os))))))))
 110
 111 (define* (switch-to-system eval os #:optional profile)
 112   "Using EVAL, a monadic procedure taking a single G-Expression as an argument,
 113 create a new generation of PROFILE pointing to the directory of OS, switch to
 114 it atomically, and run OS's activation script."
 115   (eval #~(parameterize ((current-warning-port (%make-void-port "w")))
 116             (primitive-load #$(switch-system-program os profile)))))
 117
 118 \f
 119 ;;;
 120 ;;; Services.
 121 ;;;
 122
 123 (define (running-services eval)
 124   "Using EVAL, a monadic procedure taking a single G-Expression as an argument,
 125 return the <live-service> objects that are currently running on MACHINE."
 126   (define exp
 127     (with-imported-modules '((gnu services herd))
 128       #~(begin
 129           (use-modules (gnu services herd)
 130                        (ice-9 match))
 131
 132           (let ((services (current-services)))
 133             (and services
 134                  (map (lambda (service)
 135                         (list (live-service-provision service)
 136                               (live-service-requirement service)
 137                               (match (live-service-running service)
 138                                 (#f #f)
 139                                 (#t #t)
 140                                 ((? number? pid) pid)
 141                                 (_ #t))))         ;not serializable
 142                       services))))))
 143
 144   (mlet %store-monad ((services (eval exp)))
 145     (return (map (match-lambda
 146                    ((provision requirement running)
 147                     (live-service provision requirement running)))
 148                  services))))
 149
 150 ;; XXX: Currently, this does NOT attempt to restart running services. See
 151 ;; <https://issues.guix.info/issue/33508> for details.
 152 (define (upgrade-services-program service-files to-start to-unload to-restart)
 153   "Return an executable store item that, upon being evaluated, will upgrade
 154 the Shepherd (PID 1) by unloading obsolete services and loading new
 155 services. SERVICE-FILES is a list of Shepherd service files to load, and
 156 TO-START, TO-UNLOAD, and TO-RESTART are lists of the Shepherd services'
 157 canonical names (symbols)."
 158   (program-file
 159    "upgrade-shepherd-services.scm"
 160    (with-imported-modules '((gnu services herd))
 161     #~(begin
 162         (use-modules (gnu services herd)
 163                      (srfi srfi-1))
 164
 165         ;; Load the service files for any new services.
 166         ;; Silence messages coming from shepherd such as "Evaluating
 167         ;; expression ..." since they are unhelpful.
 168         (parameterize ((shepherd-message-port (%make-void-port "w")))
 169           (load-services/safe '#$service-files))
 170
 171         ;; Unload obsolete services and start new services.
 172         (for-each unload-service '#$to-unload)
 173         (for-each start-service '#$to-start)))))
 174
 175 (define* (upgrade-shepherd-services eval os)
 176   "Using EVAL, a monadic procedure taking a single G-Expression as an argument,
 177 upgrade the Shepherd (PID 1) by unloading obsolete services and loading new
 178 services as defined by OS."
 179   (define target-services
 180     (service-value
 181      (fold-services (operating-system-services os)
 182                     #:target-type shepherd-root-service-type)))
 183
 184   (mlet* %store-monad ((live-services (running-services eval)))
 185     (let*-values (((to-unload to-restart)
 186                    (shepherd-service-upgrade live-services target-services)))
 187       (let* ((to-unload  (map live-service-canonical-name to-unload))
 188              (to-restart (map shepherd-service-canonical-name to-restart))
 189              (running    (map live-service-canonical-name
 190                               (filter live-service-running live-services)))
 191              (to-start   (lset-difference eqv?
 192                                           (map shepherd-service-canonical-name
 193                                                target-services)
 194                                           running))
 195              (service-files (map shepherd-service-file target-services)))
 196         (eval #~(parameterize ((current-warning-port (%make-void-port "w")))
 197                   (primitive-load #$(upgrade-services-program service-files
 198                                                               to-start
 199                                                               to-unload
 200                                                               to-restart))))))))
 201
 202 \f
 203 ;;;
 204 ;;; Bootloader configuration.
 205 ;;;
 206
 207 (define (install-bootloader-program installer disk-installer
 208                                     bootloader-package bootcfg
 209                                     bootcfg-file device target)
 210   "Return an executable store item that, upon being evaluated, will install
 211 BOOTCFG to BOOTCFG-FILE, a target file name, on DEVICE, a file system device,
 212 at TARGET, a mount point, and subsequently run INSTALLER from
 213 BOOTLOADER-PACKAGE."
 214   (program-file
 215    "install-bootloader.scm"
 216    (with-extensions (list guile-gcrypt)
 217      (with-imported-modules `(,@(source-module-closure
 218                                  '((gnu build bootloader)
 219                                    (gnu build install)
 220                                    (guix store)
 221                                    (guix utils))
 222                                  #:select? not-config?)
 223                               ((guix config) => ,(make-config.scm)))
 224        #~(begin
 225            (use-modules (gnu build bootloader)
 226                         (gnu build install)
 227                         (guix build utils)
 228                         (guix store)
 229                         (guix utils)
 230                         (ice-9 binary-ports)
 231                         (ice-9 match)
 232                         (srfi srfi-34)
 233                         (srfi srfi-35))
 234
 235            (let* ((gc-root (string-append #$target %gc-roots-directory "/bootcfg"))
 236                   (new-gc-root (string-append gc-root ".new")))
 237              ;; #$bootcfg has dependencies.
 238              ;; The bootloader magically loads the configuration from
 239              ;; (string-append #$target #$bootcfg-file) (for example
 240              ;; "/boot/grub/grub.cfg").
 241              ;; If we didn't do something special, the garbage collector
 242              ;; would remove the dependencies of #$bootcfg.
 243              ;; Register #$bootcfg as a GC root.
 244              ;; Preserve the previous activation's garbage collector root
 245              ;; until the bootloader installer has run, so that a failure in
 246              ;; the bootloader's installer script doesn't leave the user with
 247              ;; a broken installation.
 248              (switch-symlinks new-gc-root #$bootcfg)
 249              (install-boot-config #$bootcfg #$bootcfg-file #$target)
 250              (when (or #$installer #$disk-installer)
 251                (catch #t
 252                  (lambda ()
 253                    ;; The bootloader might not support installation on a
 254                    ;; mounted directory using the BOOTLOADER-INSTALLER
 255                    ;; procedure. In that case, fallback to installing the
 256                    ;; bootloader directly on DEVICE using the
 257                    ;; BOOTLOADER-DISK-IMAGE-INSTALLER procedure.
 258                    (if #$installer
 259                        (#$installer #$bootloader-package #$device #$target)
 260                        (#$disk-installer #$bootloader-package 0 #$device)))
 261                  (lambda args
 262                    (delete-file new-gc-root)
 263                    (match args
 264                      (('%exception exception)     ;Guile 3 SRFI-34 or similar
 265                       (raise-exception exception))
 266                      ((key . args)
 267                       (apply throw key args))))))
 268              ;; We are sure that the installation of the bootloader
 269              ;; succeeded, so we can replace the old GC root by the new
 270              ;; GC root now.
 271              (rename-file new-gc-root gc-root)))))))
 272
 273 (define* (install-bootloader eval configuration bootcfg
 274                              #:key
 275                              (run-installer? #t)
 276                              (target "/"))
 277   "Using EVAL, a monadic procedure taking a single G-Expression as an argument,
 278 configure the bootloader on TARGET such that OS will be booted by default and
 279 additional configurations specified by MENU-ENTRIES can be selected."
 280   (let* ((bootloader (bootloader-configuration-bootloader configuration))
 281          (installer (and run-installer?
 282                          (bootloader-installer bootloader)))
 283          (disk-installer (and run-installer?
 284                               (bootloader-disk-image-installer bootloader)))
 285          (package (bootloader-package bootloader))
 286          (device (bootloader-configuration-target configuration))
 287          (bootcfg-file (bootloader-configuration-file bootloader)))
 288     (eval #~(parameterize ((current-warning-port (%make-void-port "w")))
 289               (primitive-load #$(install-bootloader-program installer
 290                                                             disk-installer
 291                                                             package
 292                                                             bootcfg
 293                                                             bootcfg-file
 294                                                             device
 295                                                             target))))))
 296
 297 \f
 298 ;;;
 299 ;;; Downgrade detection.
 300 ;;;
 301
 302 (define (ensure-forward-reconfigure channel start commit relation)
 303   "Raise an error if RELATION is not 'ancestor, meaning that START is not an
 304 ancestor of COMMIT, unless CHANNEL specifies a commit."
 305   (match relation
 306     ('ancestor #t)
 307     ('self #t)
 308     (_
 309      (raise (make-compound-condition
 310              (condition
 311               (&message (message
 312                          (format #f (G_ "\
 313 aborting reconfiguration because commit ~a of channel '~a' is not a descendant of ~a")
 314                                  commit (channel-name channel)
 315                                  start)))
 316               (&fix-hint
 317                (hint (G_ "Use @option{--allow-downgrades} to force
 318 this downgrade.")))))))))
 319
 320 (define (warn-about-backward-reconfigure channel start commit relation)
 321   "Warn about non-forward updates of CHANNEL from START to COMMIT, without
 322 aborting."
 323   (match relation
 324     ((or 'ancestor 'self)
 325      #t)
 326     ('descendant
 327      (warning (G_ "rolling back channel '~a' from ~a to ~a~%")
 328               (channel-name channel) start commit))
 329     ('unrelated
 330      (warning (G_ "moving channel '~a' from ~a to unrelated commit ~a~%")
 331               (channel-name channel) start commit))))
 332
 333 (define (channel-relations old new)
 334   "Return a list of channel/relation pairs, where each relation is a symbol as
 335 returned by 'commit-relation' denoting how commits of channels in OLD relate
 336 to commits of channels in NEW."
 337   (filter-map (lambda (old)
 338                 (let ((new (find (lambda (channel)
 339                                    (eq? (channel-name channel)
 340                                         (channel-name old)))
 341                                  new)))
 342                   (and new
 343                        (let-values (((checkout commit relation)
 344                                      (update-cached-checkout
 345                                       (channel-url new)
 346                                       #:ref
 347                                       `(commit . ,(channel-commit new))
 348                                       #:starting-commit
 349                                       (channel-commit old)
 350                                       #:check-out? #f)))
 351                          (list new
 352                                (channel-commit old) (channel-commit new)
 353                                relation)))))
 354               old))
 355
 356 (define* (check-forward-update #:optional
 357                                (validate-reconfigure
 358                                 ensure-forward-reconfigure)
 359                                #:key
 360                                (current-channels
 361                                 (system-provenance "/run/current-system")))
 362   "Call VALIDATE-RECONFIGURE passing it, for each channel, the channel, the
 363 currently-deployed commit (from CURRENT-CHANNELS, which is as returned by
 364 'guix system describe' by default) and the target commit (as returned by 'guix
 365 describe')."
 366   (define new
 367     (or (and=> (current-profile) profile-channels)
 368         '()))
 369
 370   (when (null? current-channels)
 371     (warning (G_ "cannot determine provenance for current system~%")))
 372   (when (and (null? new) (not (getenv "GUIX_UNINSTALLED")))
 373     (warning (G_ "cannot determine provenance of ~a~%") %guix-package-name))
 374
 375   (for-each (match-lambda
 376               ((channel old new relation)
 377                (validate-reconfigure channel old new relation)))
 378             (channel-relations current-channels new)))