summaryrefslogtreecommitdiff
path: root/guix/scripts
diff options
context:
space:
mode:
Diffstat (limited to 'guix/scripts')
-rw-r--r--guix/scripts/build.scm13
-rw-r--r--guix/scripts/system.scm181
-rw-r--r--guix/scripts/system/reconfigure.scm232
3 files changed, 277 insertions, 149 deletions
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index ec58ba871b..3ee0b737fe 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -341,10 +341,15 @@ strings like \"guile-next=cabba9e\" meaning that packages are built using
(define (replace old url commit)
(package
(inherit old)
- (version (string-append "git."
- (if (< (string-length commit) 7)
- commit
- (string-take commit 7))))
+ (version (if (and (> (string-length commit) 1)
+ (string-prefix? "v" commit)
+ (char-set-contains? char-set:digit
+ (string-ref commit 1)))
+ (string-drop commit 1) ;looks like a tag like "v1.0"
+ (string-append "git."
+ (if (< (string-length commit) 7)
+ commit
+ (string-take commit 7)))))
(source (git-checkout (url url) (commit commit)
(recursive? #t)))))
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 67a4071684..9fc3a10e98 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -41,6 +41,7 @@
delete-matching-generations)
#:use-module (guix graph)
#:use-module (guix scripts graph)
+ #:use-module (guix scripts system reconfigure)
#:use-module (guix build utils)
#:use-module (guix progress)
#:use-module ((guix build syscalls) #:select (terminal-columns))
@@ -178,43 +179,9 @@ TARGET, and register them."
(return *unspecified*)))
-(define* (install-bootloader installer
- #:key
- bootcfg bootcfg-file
- target)
- "Run INSTALLER, a bootloader installation script, with error handling, in
-%STORE-MONAD."
- (mlet %store-monad ((installer-drv (if installer
- (lower-object installer)
- (return #f)))
- (bootcfg (lower-object bootcfg)))
- (let* ((gc-root (string-append target %gc-roots-directory
- "/bootcfg"))
- (temp-gc-root (string-append gc-root ".new"))
- (install (and installer-drv
- (derivation->output-path installer-drv)))
- (bootcfg (derivation->output-path bootcfg)))
- ;; Prepare the symlink to bootloader config file to make sure that it's
- ;; a GC root when 'installer-drv' completes (being a bit paranoid.)
- (switch-symlinks temp-gc-root bootcfg)
-
- (unless (false-if-exception
- (begin
- (install-boot-config bootcfg bootcfg-file target)
- (when install
- (save-load-path-excursion (primitive-load install)))))
- (delete-file temp-gc-root)
- (leave (G_ "failed to install bootloader ~a~%") install))
-
- ;; Register bootloader config file as a GC root so that its dependencies
- ;; (background image, font, etc.) are not reclaimed.
- (rename-file temp-gc-root gc-root)
- (return #t))))
-
(define* (install os-drv target
#:key (log-port (current-output-port))
- bootloader-installer install-bootloader?
- bootcfg bootcfg-file)
+ install-bootloader? bootloader bootcfg)
"Copy the closure of BOOTCFG, which includes the output of OS-DRV, to
directory TARGET. TARGET must be an absolute directory name since that's what
'register-path' expects.
@@ -265,10 +232,11 @@ the ownership of '~a' may be incorrect!~%")
(populate os-dir target)
(mwhen install-bootloader?
- (install-bootloader bootloader-installer
- #:bootcfg bootcfg
- #:bootcfg-file bootcfg-file
- #:target target))))))
+ (install-bootloader local-eval bootloader bootcfg
+ #:target target)
+ (return
+ (info (G_ "bootloader successfully installed on '~a'~%")
+ (bootloader-configuration-target bootloader))))))))
;;;
@@ -335,82 +303,6 @@ unload."
(warning (G_ "failed to obtain list of shepherd services~%"))
(return #f)))))
-(define (upgrade-shepherd-services os)
- "Upgrade the Shepherd (PID 1) by unloading obsolete services and loading new
-services specified in OS and not currently running.
-
-This is currently very conservative in that it does not stop or unload any
-running service. Unloading or stopping the wrong service ('udev', say) could
-bring the system down."
- (define new-services
- (service-value
- (fold-services (operating-system-services os)
- #:target-type shepherd-root-service-type)))
-
- ;; Arrange to simply emit a warning if the service upgrade fails.
- (with-shepherd-error-handling
- (call-with-service-upgrade-info new-services
- (lambda (to-restart to-unload)
- (for-each (lambda (unload)
- (info (G_ "unloading service '~a'...~%") unload)
- (unload-service unload))
- to-unload)
-
- (with-monad %store-monad
- (munless (null? new-services)
- (let ((new-service-names (map shepherd-service-canonical-name new-services))
- (to-restart-names (map shepherd-service-canonical-name to-restart))
- (to-start (filter shepherd-service-auto-start? new-services)))
- (info (G_ "loading new services:~{ ~a~}...~%") new-service-names)
- (unless (null? to-restart-names)
- ;; Listing TO-RESTART-NAMES in the message below wouldn't help
- ;; because many essential services cannot be meaningfully
- ;; restarted. See <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=22039#30>.
- (format #t (G_ "To complete the upgrade, run 'herd restart SERVICE' to stop,
-upgrade, and restart each service that was not automatically restarted.\n")))
- (mlet %store-monad ((files (mapm %store-monad
- (compose lower-object
- shepherd-service-file)
- new-services)))
- ;; Here we assume that FILES are exactly those that were computed
- ;; as part of the derivation that built OS, which is normally the
- ;; case.
- (load-services/safe (map derivation->output-path files))
-
- (for-each start-service
- (map shepherd-service-canonical-name to-start))
- (return #t)))))))))
-
-(define* (switch-to-system os
- #:optional (profile %system-profile))
- "Make a new generation of PROFILE pointing to the directory of OS, switch to
-it atomically, and then run OS's activation script."
- (mlet* %store-monad ((drv (operating-system-derivation os))
- (script (lower-object (operating-system-activation-script os))))
- (let* ((system (derivation->output-path drv))
- (number (+ 1 (generation-number profile)))
- (generation (generation-file-name profile number)))
- (switch-symlinks generation system)
- (switch-symlinks profile generation)
-
- (format #t (G_ "activating system...~%"))
-
- ;; The activation script may change $PATH, among others, so protect
- ;; against that.
- (save-environment-excursion
- ;; Tell 'activate-current-system' what the new system is.
- (setenv "GUIX_NEW_SYSTEM" system)
-
- ;; The activation script may modify '%load-path' & co., so protect
- ;; against that. This is necessary to ensure that
- ;; 'upgrade-shepherd-services' gets to see the right modules when it
- ;; computes derivations with 'gexp->derivation'.
- (save-load-path-excursion
- (primitive-load (derivation->output-path script))))
-
- ;; Finally, try to update system services.
- (upgrade-shepherd-services os))))
-
(define-syntax-rule (unless-file-not-found exp)
(catch 'system-error
(lambda ()
@@ -505,18 +397,13 @@ STORE is an open connection to the store."
((bootloader-configuration-file-generator bootloader)
bootloader-config entries
#:old-entries old-entries)))
- (bootcfg-file -> (bootloader-configuration-file bootloader))
- (target -> "/")
(drvs -> (list bootcfg)))
(mbegin %store-monad
(show-what-to-build* drvs)
(built-derivations drvs)
- ;; Only install bootloader configuration file. Thus, no installer is
- ;; provided here.
- (install-bootloader #f
- #:bootcfg bootcfg
- #:bootcfg-file bootcfg-file
- #:target target))))))
+ ;; Only install bootloader configuration file.
+ (install-bootloader local-eval bootloader-config bootcfg
+ #:run-installer? #f))))))
;;;
@@ -820,8 +707,17 @@ and TARGET arguments."
(condition-message c))
(exit 1)))
(#$installer #$bootloader #$device #$target)
- (format #t "bootloader successfully installed on '~a'~%"
- #$device))))))
+ (info (G_ "bootloader successfully installed on '~a'~%")
+ #$device))))))
+
+(define (local-eval exp)
+ "Evaluate EXP, a G-Expression, in-place."
+ (mlet* %store-monad ((lowered (lower-gexp exp))
+ (_ (built-derivations (lowered-gexp-inputs lowered))))
+ (save-load-path-excursion
+ (set! %load-path (lowered-gexp-load-path lowered))
+ (set! %load-compiled-path (lowered-gexp-load-compiled-path lowered))
+ (return (primitive-eval (lowered-gexp-sexp lowered))))))
(define* (perform-action action os
#:key skip-safety-checks?
@@ -858,19 +754,12 @@ static checks."
(map boot-parameters->menu-entry (profile-boot-parameters))))
(define bootloader
- (bootloader-configuration-bootloader (operating-system-bootloader os)))
+ (operating-system-bootloader os))
(define bootcfg
(and (memq action '(init reconfigure))
(operating-system-bootcfg os menu-entries)))
- (define bootloader-script
- (let ((installer (bootloader-installer bootloader))
- (target (or target "/")))
- (bootloader-installer-script installer
- (bootloader-package bootloader)
- bootloader-target target)))
-
(when (eq? action 'reconfigure)
(maybe-suggest-running-guix-pull))
@@ -897,9 +786,7 @@ static checks."
;; See <http://bugs.gnu.org/21068>.
(drvs (mapm %store-monad lower-object
(if (memq action '(init reconfigure))
- (if install-bootloader?
- (list sys bootcfg bootloader-script)
- (list sys bootcfg))
+ (list sys bootcfg)
(list sys))))
(% (if derivations-only?
(return (for-each (compose println derivation-file-name)
@@ -909,28 +796,32 @@ static checks."
(if (or dry-run? derivations-only?)
(return #f)
- (let ((bootcfg-file (bootloader-configuration-file bootloader)))
+ (begin
(for-each (compose println derivation->output-path)
drvs)
(case action
((reconfigure)
+ (newline)
+ (format #t (G_ "activating system...~%"))
(mbegin %store-monad
- (switch-to-system os)
+ (switch-to-system local-eval os)
(mwhen install-bootloader?
- (install-bootloader bootloader-script
- #:bootcfg bootcfg
- #:bootcfg-file bootcfg-file
- #:target "/"))))
+ (install-bootloader local-eval bootloader bootcfg
+ #:target (or target "/"))
+ (return
+ (info (G_ "bootloader successfully installed on '~a'~%")
+ (bootloader-configuration-target bootloader))))
+ (with-shepherd-error-handling
+ (upgrade-shepherd-services local-eval os))))
((init)
(newline)
(format #t (G_ "initializing operating system under '~a'...~%")
target)
(install sys (canonicalize-path target)
#:install-bootloader? install-bootloader?
- #:bootcfg bootcfg
- #:bootcfg-file bootcfg-file
- #:bootloader-installer bootloader-script))
+ #:bootloader bootloader
+ #:bootcfg bootcfg))
(else
;; All we had to do was to build SYS and maybe register an
;; indirect GC root.
diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm
new file mode 100644
index 0000000000..dee0c24bd2
--- /dev/null
+++ b/guix/scripts/system/reconfigure.scm
@@ -0,0 +1,232 @@
+;;; 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)))))