diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/build.scm | 13 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 181 | ||||
| -rw-r--r-- | guix/scripts/system/reconfigure.scm | 232 |
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))))) |