guix-devel/guix/scripts/system/reconfigure.scm

;;; 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 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 (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:export (switch-system-program
            switch-to-system

            upgrade-services-program
            upgrade-shepherd-services

            install-bootloader-program
            install-bootloader))

;;; 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* (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 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)
             (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 #~(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.
        (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 #~(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)))
       #~(begin
           (use-modules (gnu build bootloader)
                        (gnu build install)
                        (guix build utils)
                        (guix store)
                        (guix utils)
                        (ice-9 binary-ports)
                        (srfi srfi-34)
                        (srfi srfi-35))
           (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)
             (install-boot-config #$bootcfg #$bootcfg-file #$target)
             ;; 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.
             (when #$installer
               (catch #t
                 (lambda ()
                   (#$installer #$bootloader-package #$device #$target))
                 (lambda args
                   (delete-file temp-gc-root)
                   (apply throw args))))
             (rename-file temp-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 #~(primitive-load #$(install-bootloader-program installer
                                                          package
                                                          bootcfg
                                                          bootcfg-file
                                                          device
                                                          target)))))