nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

guix system: Reimplement 'reconfigure'. 

* guix/scripts/system.scm (switch-to-system)
(upgrade-shepherd-services, install-bootloader): Delete variable.
(local-eval): New variable.
(install): Remove 'bootloader-installer' and 'bootcfg-file' parameters.
(install): Add 'bootloader' parameter.

Signed-off-by: Ludovic Courtès <ludo@gnu.org>
This commit is contained in:
Jakob L. Kreuze 2019-07-24 12:34:38 -04:00 committed by Ludovic Courtès
parent 5c793753b3
commit 5c8c8c4554
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 36 additions and 145 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

181
guix/scripts/system.scm
View File

@ -41,6 +41,7 @@
delete-matching-generations) delete-matching-generations)
#:use-module (guix graph) #:use-module (guix graph)
#:use-module (guix scripts graph) #:use-module (guix scripts graph)
#:use-module (guix scripts system reconfigure)
#:use-module (guix build utils) #:use-module (guix build utils)
#:use-module (guix progress) #:use-module (guix progress)
#:use-module ((guix build syscalls) #:select (terminal-columns)) #:use-module ((guix build syscalls) #:select (terminal-columns))
@ -178,43 +179,9 @@ TARGET, and register them."
(return *unspecified*))) (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 (define* (install os-drv target
#:key (log-port (current-output-port)) #:key (log-port (current-output-port))
bootloader-installer install-bootloader? install-bootloader? bootloader bootcfg)
bootcfg bootcfg-file)
"Copy the closure of BOOTCFG, which includes the output of OS-DRV, to "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 directory TARGET. TARGET must be an absolute directory name since that's what
'register-path' expects. 'register-path' expects.
@ -265,10 +232,11 @@ the ownership of '~a' may be incorrect!~%")
(populate os-dir target) (populate os-dir target)
(mwhen install-bootloader? (mwhen install-bootloader?
(install-bootloader bootloader-installer (install-bootloader local-eval bootloader bootcfg
#:bootcfg bootcfg #:target target)
#:bootcfg-file bootcfg-file (return
#:target target)))))) (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~%")) (warning (G_ "failed to obtain list of shepherd services~%"))
(return #f))))) (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) (define-syntax-rule (unless-file-not-found exp)
(catch 'system-error (catch 'system-error
(lambda () (lambda ()
@ -505,18 +397,13 @@ STORE is an open connection to the store."
((bootloader-configuration-file-generator bootloader) ((bootloader-configuration-file-generator bootloader)
bootloader-config entries bootloader-config entries
#:old-entries old-entries))) #:old-entries old-entries)))
(bootcfg-file -> (bootloader-configuration-file bootloader))
(target -> "/")
(drvs -> (list bootcfg))) (drvs -> (list bootcfg)))
(mbegin %store-monad (mbegin %store-monad
(show-what-to-build* drvs) (show-what-to-build* drvs)
(built-derivations drvs) (built-derivations drvs)
;; Only install bootloader configuration file. Thus, no installer is ;; Only install bootloader configuration file.
;; provided here. (install-bootloader local-eval bootloader-config bootcfg
(install-bootloader #f #:run-installer? #f))))))
#:bootcfg bootcfg
#:bootcfg-file bootcfg-file
#:target target))))))
;;; ;;;
@ -820,8 +707,17 @@ and TARGET arguments."
(condition-message c)) (condition-message c))
(exit 1))) (exit 1)))
(#$installer #$bootloader #$device #$target) (#$installer #$bootloader #$device #$target)
(format #t "bootloader successfully installed on '~a'~%" (info (G_ "bootloader successfully installed on '~a'~%")
#$device)))))) #$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 (define* (perform-action action os
#:key skip-safety-checks? #:key skip-safety-checks?
@ -858,19 +754,12 @@ static checks."
(map boot-parameters->menu-entry (profile-boot-parameters)))) (map boot-parameters->menu-entry (profile-boot-parameters))))
(define bootloader (define bootloader
(bootloader-configuration-bootloader (operating-system-bootloader os))) (operating-system-bootloader os))
(define bootcfg (define bootcfg
(and (memq action '(init reconfigure)) (and (memq action '(init reconfigure))
(operating-system-bootcfg os menu-entries))) (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) (when (eq? action 'reconfigure)
(maybe-suggest-running-guix-pull)) (maybe-suggest-running-guix-pull))
@ -897,9 +786,7 @@ static checks."
;; See <http://bugs.gnu.org/21068>. ;; See <http://bugs.gnu.org/21068>.
(drvs (mapm %store-monad lower-object (drvs (mapm %store-monad lower-object
(if (memq action '(init reconfigure)) (if (memq action '(init reconfigure))
(if install-bootloader? (list sys bootcfg)
(list sys bootcfg bootloader-script)
(list sys bootcfg))
(list sys)))) (list sys))))
(% (if derivations-only? (% (if derivations-only?
(return (for-each (compose println derivation-file-name) (return (for-each (compose println derivation-file-name)
@ -909,28 +796,32 @@ static checks."
(if (or dry-run? derivations-only?) (if (or dry-run? derivations-only?)
(return #f) (return #f)
(let ((bootcfg-file (bootloader-configuration-file bootloader))) (begin
(for-each (compose println derivation->output-path) (for-each (compose println derivation->output-path)
drvs) drvs)
(case action (case action
((reconfigure) ((reconfigure)
(newline)
(format #t (G_ "activating system...~%"))
(mbegin %store-monad (mbegin %store-monad
(switch-to-system os) (switch-to-system local-eval os)
(mwhen install-bootloader? (mwhen install-bootloader?
(install-bootloader bootloader-script (install-bootloader local-eval bootloader bootcfg
#:bootcfg bootcfg #:target (or target "/"))
#:bootcfg-file bootcfg-file (return
#:target "/")))) (info (G_ "bootloader successfully installed on '~a'~%")
(bootloader-configuration-target bootloader))))
(with-shepherd-error-handling
(upgrade-shepherd-services local-eval os))))
((init) ((init)
(newline) (newline)
(format #t (G_ "initializing operating system under '~a'...~%") (format #t (G_ "initializing operating system under '~a'...~%")
target) target)
(install sys (canonicalize-path target) (install sys (canonicalize-path target)
#:install-bootloader? install-bootloader? #:install-bootloader? install-bootloader?
#:bootcfg bootcfg #:bootloader bootloader
#:bootcfg-file bootcfg-file #:bootcfg bootcfg))
#:bootloader-installer bootloader-script))
(else (else
;; All we had to do was to build SYS and maybe register an ;; All we had to do was to build SYS and maybe register an
;; indirect GC root. ;; indirect GC root.