diff options
| -rw-r--r-- | doc/guix.texi | 12 | ||||
| -rw-r--r-- | gnu/system.scm | 1 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 125 |
3 files changed, 116 insertions, 22 deletions
diff --git a/doc/guix.texi b/doc/guix.texi index 446c688679..76a812f23c 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3210,6 +3210,18 @@ operating system is instantiate. Currently the following values are supported: @table @code +@item reconfigure +Build the operating system described in @var{file}, activate it, and +switch to it@footnote{This action is usable only on systems already +running GNU.}. + +This effects all the configuration specified in @var{file}: user +accounts, system services, global package list, setuid programs, etc. + +It also adds a GRUB menu entry for the new OS configuration, and moves +entries for older configurations to a submenu---unless +@option{--no-grub} is passed. + @item build Build the operating system's derivation, which includes all the configuration files and programs needed to boot and run the system. diff --git a/gnu/system.scm b/gnu/system.scm index 0b62350c63..9872bb49f3 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -59,6 +59,7 @@ operating-system-timezone operating-system-locale operating-system-file-systems + operating-system-activation-script operating-system-derivation operating-system-profile diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 1bedc2c68a..fc947e4016 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -17,6 +17,7 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix scripts system) + #:use-module (guix config) #:use-module (guix ui) #:use-module (guix store) #:use-module (guix gexp) @@ -24,6 +25,7 @@ #:use-module (guix packages) #:use-module (guix utils) #:use-module (guix monads) + #:use-module (guix profiles) #:use-module (guix scripts build) #:use-module (guix build utils) #:use-module (guix build install) @@ -122,6 +124,70 @@ When GRUB? is true, install GRUB on DEVICE, using GRUB.CFG." ;;; +;;; Reconfiguration. +;;; + +(define %system-profile + ;; The system profile. + (string-append %state-directory "/profiles/system")) + +(define* (switch-to-system store os system + #:optional (profile %system-profile)) + "Make a new generation of PROFILE pointing to SYSTEM, which is the directory +corresponding to OS, switch to it atomically, and then run OS's activation +script." + (let* ((number (+ 1 (generation-number profile))) + (generation (generation-file-name profile number))) + (symlink system generation) + (switch-symlinks profile generation) + + (run-with-store store + (mlet %store-monad ((script (operating-system-activation-script os))) + (format #t (_ "activating system...~%")) + (return (primitive-load (derivation->output-path script))))) + + ;; TODO: Run 'deco reload ...'. + )) + +(define-syntax-rule (unless-file-not-found exp) + (catch 'system-error + (lambda () + exp) + (lambda args + (if (= ENOENT (system-error-errno args)) + #f + (apply throw args))))) + +(define* (previous-grub-entries #:optional (profile %system-profile)) + "Return a list of 'menu-entry' for the generations of PROFILE." + (define (system->grub-entry system) + (unless-file-not-found + (call-with-input-file (string-append system "/parameters") + (lambda (port) + (match (read port) + (('boot-parameters ('version 0) + ('label label) ('root-device root) + ('kernel linux) + _ ...) + (menu-entry + (label label) + (linux linux) + (linux-arguments + (list (string-append "--root=" root) + #~(string-append "--system=" #$system) + #~(string-append "--load=" #$system "/boot"))) + (initrd #~(string-append #$system "/initrd")))) + (_ ;unsupported format + (warning (_ "unrecognized boot parameters for '~a'~%") + system) + #f)))))) + + (let ((systems (map (cut generation-file-name profile <>) + (generation-numbers profile)))) + (filter-map system->grub-entry systems))) + + +;;; ;;; Options. ;;; @@ -131,6 +197,8 @@ Build the operating system declared in FILE according to ACTION.\n")) (newline) (display (_ "The valid values for ACTION are:\n")) (display (_ "\ + - 'reconfigure', switch to a new operating system configuration\n")) + (display (_ "\ - 'build', build the operating system without installing anything\n")) (display (_ "\ - 'vm', build a virtual machine image that shares the host's store\n")) @@ -201,7 +269,7 @@ Build the operating system declared in FILE according to ACTION.\n")) (alist-cons 'argument arg result) (let ((action (string->symbol arg))) (case action - ((build vm vm-image disk-image init) + ((build vm vm-image disk-image reconfigure init) (alist-cons 'action action result)) (else (leave (_ "~a: unknown action~%") action)))))) @@ -224,7 +292,7 @@ Build the operating system declared in FILE according to ACTION.\n")) action)) (case action - ((build vm vm-image disk-image) + ((build vm vm-image disk-image reconfigure) (unless (= count 1) (fail))) ((init) @@ -241,7 +309,7 @@ Build the operating system declared in FILE according to ACTION.\n")) (read-operating-system file) (leave (_ "no configuration file specified~%")))) (mdrv (case action - ((build init) + ((build init reconfigure) (operating-system-derivation os)) ((vm-image) (let ((size (assoc-ref opts 'image-size))) @@ -257,8 +325,9 @@ Build the operating system declared in FILE according to ACTION.\n")) (dry? (assoc-ref opts 'dry-run?)) (drv (run-with-store store mdrv)) (grub? (assoc-ref opts 'install-grub?)) + (old (previous-grub-entries)) (grub.cfg (run-with-store store - (operating-system-grub.cfg os))) + (operating-system-grub.cfg os old))) (grub (package-derivation store grub)) (drv-lst (if grub? (list drv grub grub.cfg) @@ -273,21 +342,33 @@ Build the operating system declared in FILE according to ACTION.\n")) (display (derivation->output-path drv)) (newline) - (when (eq? action 'init) - (let* ((target (second args)) - (device (grub-configuration-device - (operating-system-bootloader os)))) - (format #t (_ "initializing operating system under '~a'...~%") - target) - - (when grub - (let ((prefix (derivation->output-path grub))) - (setenv "PATH" - (string-append prefix "/bin:" prefix "/sbin:" - (getenv "PATH"))))) - - (install store (derivation->output-path drv) - (canonicalize-path target) - #:grub? grub? - #:grub.cfg (derivation->output-path grub.cfg) - #:device device))))))) + ;; Make sure GRUB is accessible. + (when grub + (let ((prefix (derivation->output-path grub))) + (setenv "PATH" + (string-append prefix "/bin:" prefix "/sbin:" + (getenv "PATH"))))) + + (let ((target (match args + ((first second) second) + (_ #f))) + (device (and grub? + (grub-configuration-device + (operating-system-bootloader os))))) + (case action + ((reconfigure) + (switch-to-system store os (derivation->output-path drv)) + (when grub? + (unless (install-grub grub.cfg device target) + (leave (_ "failed to install GRUB on device '~a'~%") device)))) + ((init) + (format #t (_ "initializing operating system under '~a'...~%") + target) + + (install store (derivation->output-path drv) + (canonicalize-path target) + #:grub? grub? + #:grub.cfg (derivation->output-path grub.cfg) + #:device device)))))))) + +;;; system.scm ends here |