guix system: Add 'reconfigure' action.

* guix/scripts/system.scm (%system-profile): New variable.
  (switch-to-system, previous-grub-entries): New procedures.
  (unless-file-not-found): New macro.
  (show-help): Add 'reconfigure'.
  (guix-system): Handle it.
* gnu/system.scm: Export 'operating-system-activation-script'.
* doc/guix.texi (Invoking guix system): Document it.
This commit is contained in:
Ludovic Courtès 2014-06-27 00:06:46 +02:00
parent f01efec09a
commit b25937e318
3 changed files with 114 additions and 20 deletions

View File

@ -3210,6 +3210,18 @@ operating system is instantiate. Currently the following values are
supported: supported:
@table @code @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 @item build
Build the operating system's derivation, which includes all the Build the operating system's derivation, which includes all the
configuration files and programs needed to boot and run the system. configuration files and programs needed to boot and run the system.

View File

@ -59,6 +59,7 @@
operating-system-timezone operating-system-timezone
operating-system-locale operating-system-locale
operating-system-file-systems operating-system-file-systems
operating-system-activation-script
operating-system-derivation operating-system-derivation
operating-system-profile operating-system-profile

View File

@ -17,6 +17,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix scripts system) (define-module (guix scripts system)
#:use-module (guix config)
#:use-module (guix ui) #:use-module (guix ui)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix gexp) #:use-module (guix gexp)
@ -24,6 +25,7 @@
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (guix monads) #:use-module (guix monads)
#:use-module (guix profiles)
#:use-module (guix scripts build) #:use-module (guix scripts build)
#:use-module (guix build utils) #:use-module (guix build utils)
#:use-module (guix build install) #:use-module (guix build install)
@ -120,6 +122,70 @@ When GRUB? is true, install GRUB on DEVICE, using GRUB.CFG."
(unless (false-if-exception (install-grub grub.cfg device target)) (unless (false-if-exception (install-grub grub.cfg device target))
(leave (_ "failed to install GRUB on device '~a'~%") device)))) (leave (_ "failed to install GRUB on device '~a'~%") device))))
;;;
;;; 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. ;;; Options.
@ -131,6 +197,8 @@ Build the operating system declared in FILE according to ACTION.\n"))
(newline) (newline)
(display (_ "The valid values for ACTION are:\n")) (display (_ "The valid values for ACTION are:\n"))
(display (_ "\ (display (_ "\
- 'reconfigure', switch to a new operating system configuration\n"))
(display (_ "\
- 'build', build the operating system without installing anything\n")) - 'build', build the operating system without installing anything\n"))
(display (_ "\ (display (_ "\
- 'vm', build a virtual machine image that shares the host's store\n")) - '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) (alist-cons 'argument arg result)
(let ((action (string->symbol arg))) (let ((action (string->symbol arg)))
(case action (case action
((build vm vm-image disk-image init) ((build vm vm-image disk-image reconfigure init)
(alist-cons 'action action result)) (alist-cons 'action action result))
(else (leave (_ "~a: unknown action~%") (else (leave (_ "~a: unknown action~%")
action)))))) action))))))
@ -224,7 +292,7 @@ Build the operating system declared in FILE according to ACTION.\n"))
action)) action))
(case action (case action
((build vm vm-image disk-image) ((build vm vm-image disk-image reconfigure)
(unless (= count 1) (unless (= count 1)
(fail))) (fail)))
((init) ((init)
@ -241,7 +309,7 @@ Build the operating system declared in FILE according to ACTION.\n"))
(read-operating-system file) (read-operating-system file)
(leave (_ "no configuration file specified~%")))) (leave (_ "no configuration file specified~%"))))
(mdrv (case action (mdrv (case action
((build init) ((build init reconfigure)
(operating-system-derivation os)) (operating-system-derivation os))
((vm-image) ((vm-image)
(let ((size (assoc-ref opts 'image-size))) (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?)) (dry? (assoc-ref opts 'dry-run?))
(drv (run-with-store store mdrv)) (drv (run-with-store store mdrv))
(grub? (assoc-ref opts 'install-grub?)) (grub? (assoc-ref opts 'install-grub?))
(old (previous-grub-entries))
(grub.cfg (run-with-store store (grub.cfg (run-with-store store
(operating-system-grub.cfg os))) (operating-system-grub.cfg os old)))
(grub (package-derivation store grub)) (grub (package-derivation store grub))
(drv-lst (if grub? (drv-lst (if grub?
(list drv grub grub.cfg) (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)) (display (derivation->output-path drv))
(newline) (newline)
(when (eq? action 'init) ;; Make sure GRUB is accessible.
(let* ((target (second args)) (when grub
(device (grub-configuration-device (let ((prefix (derivation->output-path grub)))
(operating-system-bootloader os)))) (setenv "PATH"
(format #t (_ "initializing operating system under '~a'...~%") (string-append prefix "/bin:" prefix "/sbin:"
target) (getenv "PATH")))))
(when grub (let ((target (match args
(let ((prefix (derivation->output-path grub))) ((first second) second)
(setenv "PATH" (_ #f)))
(string-append prefix "/bin:" prefix "/sbin:" (device (and grub?
(getenv "PATH"))))) (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) (install store (derivation->output-path drv)
(canonicalize-path target) (canonicalize-path target)
#:grub? grub? #:grub? grub?
#:grub.cfg (derivation->output-path grub.cfg) #:grub.cfg (derivation->output-path grub.cfg)
#:device device))))))) #:device device))))))))
;;; system.scm ends here