From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:470:142:3::10]:42468) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hjXwv-0007fE-QN for guix-patches@gnu.org; Fri, 05 Jul 2019 19:49:07 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hjXwu-0005qJ-4B for guix-patches@gnu.org; Fri, 05 Jul 2019 19:49:05 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:45173) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1hjXwu-0005qB-0z for guix-patches@gnu.org; Fri, 05 Jul 2019 19:49:04 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1hjXwt-0007fr-T0 for guix-patches@gnu.org; Fri, 05 Jul 2019 19:49:03 -0400 Subject: [bug#36404] [PATCH 3/3] guix system: Reimplement 'reconfigure'. Resent-Message-ID: From: zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) References: <87o92ianbj.fsf@sdf.lonestar.org> <87o92glap5.fsf@dustycloud.org> <878sthoqzi.fsf@gnu.org> <87r2799tzd.fsf@sdf.lonestar.org> <87d0isrsmk.fsf@sdf.lonestar.org> <878std3fw0.fsf@sdf.lonestar.org> <87wogwoqrg.fsf@gnu.org> <87bly8f3kq.fsf_-_@sdf.lonestar.org> <877e8wf3iz.fsf_-_@sdf.lonestar.org> <8736jkf3h5.fsf_-_@sdf.lonestar.org> Date: Fri, 05 Jul 2019 19:48:36 -0400 In-Reply-To: <8736jkf3h5.fsf_-_@sdf.lonestar.org> (Jakob L. Kreuze's message of "Fri, 05 Jul 2019 19:47:50 -0400") Message-ID: <87y31cdovf.fsf_-_@sdf.lonestar.org> MIME-Version: 1.0 Content-Type: multipart/signed; boundary="=-=-="; micalg=pgp-sha256; protocol="application/pgp-signature" List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+kyle=kyleam.com@gnu.org Sender: "Guix-patches" To: Ludovic =?UTF-8?Q?Court=C3=A8s?= Cc: 36404@debbugs.gnu.org --=-=-= Content-Type: text/plain Content-Transfer-Encoding: quoted-printable * guix/scripts/system.scm (switch-to-system) (upgrade-shepherd-services, install-bootloader): Delete variable. * guix/scripts/system.scm (%switch-to-system) (%upgrade-shepherd-services, %install-bootloader): New variable. =2D-- guix/scripts/system.scm | 161 +++++++++++++--------------------------- 1 file changed, 50 insertions(+), 111 deletions(-) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 21858ee7d..1f7912dcf 100644 =2D-- 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)) @@ -179,38 +180,16 @@ TARGET, and register them." =20 (return *unspecified*))) =20 =2D(define* (install-bootloader installer =2D #:key =2D bootcfg bootcfg-file =2D target) +(define (%install-bootloader installer bootcfg bootcfg-file target) "Run INSTALLER, a bootloader installation script, with error handling, in %STORE-MONAD." =2D (mlet %store-monad ((installer-drv (if installer =2D (lower-object installer) =2D (return #f))) =2D (bootcfg (lower-object bootcfg))) =2D (let* ((gc-root (string-append target %gc-roots-directory =2D "/bootcfg")) =2D (temp-gc-root (string-append gc-root ".new")) =2D (install (and installer-drv =2D (derivation->output-path installer-drv))) =2D (bootcfg (derivation->output-path bootcfg))) =2D ;; Prepare the symlink to bootloader config file to make sure that= it's =2D ;; a GC root when 'installer-drv' completes (being a bit paranoid.) =2D (switch-symlinks temp-gc-root bootcfg) =2D =2D (unless (false-if-exception =2D (begin =2D (install-boot-config bootcfg bootcfg-file target) =2D (when install =2D (save-load-path-excursion (primitive-load install))))) =2D (delete-file temp-gc-root) =2D (leave (G_ "failed to install bootloader ~a~%") install)) =2D =2D ;; Register bootloader config file as a GC root so that its depend= encies =2D ;; (background image, font, etc.) are not reclaimed. =2D (rename-file temp-gc-root gc-root) =2D (return #t)))) + (mlet* %store-monad ((file (lower-object + (scheme-file "install-bootloader.scm" + (install-bootloader installer b= ootcfg + bootcfg-file + target)))) + (_ (built-derivations (list file)))) + (primitive-load (derivation->output-path file)))) =20 (define* (install os-drv target #:key (log-port (current-output-port)) @@ -266,10 +245,8 @@ the ownership of '~a' may be incorrect!~%") (populate os-dir target) =20 (mwhen install-bootloader? =2D (install-bootloader bootloader-installer =2D #:bootcfg bootcfg =2D #:bootcfg-file bootcfg-file =2D #:target target)))))) + (%install-bootloader bootloader-installer bootcfg + bootcfg-file target)))))) =20 ;;; @@ -336,81 +313,47 @@ unload." (warning (G_ "failed to obtain list of shepherd services~%")) (return #f))))) =20 =2D(define (upgrade-shepherd-services os) +(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. =20 This is currently very conservative in that it does not stop or unload any running service. Unloading or stopping the wrong service ('udev', say) co= uld bring the system down." =2D (define new-services =2D (service-value =2D (fold-services (operating-system-services os) =2D #:target-type shepherd-root-service-type))) =2D =2D ;; Arrange to simply emit a warning if the service upgrade fails. =2D (with-shepherd-error-handling =2D (call-with-service-upgrade-info new-services =2D (lambda (to-restart to-unload) =2D (for-each (lambda (unload) =2D (info (G_ "unloading service '~a'...~%") unload) =2D (unload-service unload)) =2D to-unload) =2D =2D (with-monad %store-monad =2D (munless (null? new-services) =2D (let ((new-service-names (map shepherd-service-canonical-na= me new-services)) =2D (to-restart-names (map shepherd-service-canonical-na= me to-restart)) =2D (to-start (filter shepherd-service-auto-star= t? new-services))) =2D (info (G_ "loading new services:~{ ~a~}...~%") new-service= -names) =2D (unless (null? to-restart-names) =2D ;; Listing TO-RESTART-NAMES in the message below wouldn'= t help =2D ;; because many essential services cannot be meaningfully =2D ;; restarted. See . =2D (format #t (G_ "To complete the upgrade, run 'herd resta= rt SERVICE' to stop, =2Dupgrade, and restart each service that was not automatically restarted.\= n"))) =2D (mlet %store-monad ((files (mapm %store-monad =2D (compose lower-object =2D shepherd-service= -file) =2D new-services))) =2D ;; Here we assume that FILES are exactly those that were= computed =2D ;; as part of the derivation that built OS, which is nor= mally the =2D ;; case. =2D (load-services/safe (map derivation->output-path files)) =2D =2D (for-each start-service =2D (map shepherd-service-canonical-name to-start)) =2D (return #t))))))))) =2D =2D(define* (switch-to-system os =2D #:optional (profile %system-profile)) =2D "Make a new generation of PROFILE pointing to the directory of OS, swi= tch to =2Dit atomically, and then run OS's activation script." + (define target-services + ;; Monadic expression evaluating to a list of + ;; (shepherd-service-canonical-name, shepherd-service-file) pairs for = the + ;; services in MACHINE's operating system configuration. + (mapm %store-monad + (lambda (service) + (mlet %store-monad ((file ((compose lower-object + shepherd-service-file) + service))) + (return (list (shepherd-service-canonical-name service) + (derivation->output-path file))))) + (service-value + (fold-services (operating-system-services os) + #:target-type shepherd-root-service-type)))) + + (mlet* %store-monad ((target-services target-services) + (file (lower-object + (scheme-file "upgrade-shepherd-services.scm" + (upgrade-shepherd-services + target-services)))) + (_ (built-derivations (list file)))) + (primitive-load (derivation->output-path file)))) + +(define (%switch-to-system os) + "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)) =2D (script (lower-object (operating-system-activatio= n-script os)))) =2D (let* ((system (derivation->output-path drv)) =2D (number (+ 1 (generation-number profile))) =2D (generation (generation-file-name profile number))) =2D (switch-symlinks generation system) =2D (switch-symlinks profile generation) =2D =2D (format #t (G_ "activating system...~%")) =2D =2D ;; The activation script may change $PATH, among others, so protect =2D ;; against that. =2D (save-environment-excursion =2D ;; Tell 'activate-current-system' what the new system is. =2D (setenv "GUIX_NEW_SYSTEM" system) =2D =2D ;; The activation script may modify '%load-path' & co., so protect =2D ;; against that. This is necessary to ensure that =2D ;; 'upgrade-shepherd-services' gets to see the right modules when= it =2D ;; computes derivations with 'gexp->derivation'. =2D (save-load-path-excursion =2D (primitive-load (derivation->output-path script)))) =2D =2D ;; Finally, try to update system services. =2D (upgrade-shepherd-services os)))) + (script (lower-object + (operating-system-activation-script os))) + (file (lower-object + (scheme-file "switch-to-system.scm" + (switch-to-system drv script)))) + (_ (built-derivations (list file)))) + (primitive-load (derivation->output-path file)))) =20 (define-syntax-rule (unless-file-not-found exp) (catch 'system-error @@ -514,10 +457,7 @@ STORE is an open connection to the store." (built-derivations drvs) ;; Only install bootloader configuration file. Thus, no installe= r is ;; provided here. =2D (install-bootloader #f =2D #:bootcfg bootcfg =2D #:bootcfg-file bootcfg-file =2D #:target target)))))) + (%install-bootloader #f bootcfg bootcfg-file target)))))) =20 ;;; @@ -919,12 +859,11 @@ static checks." (case action ((reconfigure) (mbegin %store-monad =2D (switch-to-system os) + (%switch-to-system os) + (%upgrade-shepherd-services os) (mwhen install-bootloader? =2D (install-bootloader bootloader-script =2D #:bootcfg bootcfg =2D #:bootcfg-file bootcfg-file =2D #:target "/")))) + (%install-bootloader bootloader-script bootcfg + bootcfg-file (or target "/"))))) ((init) (newline) (format #t (G_ "initializing operating system under '~a'...~%= ") =2D-=20 2.22.0 --=-=-= Content-Type: application/pgp-signature; name="signature.asc" -----BEGIN PGP SIGNATURE----- iQIzBAEBCAAdFiEEa1VJLOiXAjQ2BGSm9Qb9Fp2P2VoFAl0f4dQACgkQ9Qb9Fp2P 2VrsKw//dn5TqcKmbV6YwOKjBdXpDfHNigOgRVMaSVacJW+JPvTj/77hacFzzrUs pPL0tR+JgxkvZhlAuqeukEqHs45FcyJ9hzmpo24WFuFw8gu/CFQEuFY9g7XDxATi WFK5Ise+RpcVegsFVr947lpOSGXlGDANFII55EV8MnRB4pXBA193Vmn7ItBUSSwg HJk/k4m2LllEIPScP6da0EN9th8Lx941FPMbqbEhyNF+hnOQNXutVs83vPlx+YOc OlGUKrZ6XE8TnGr3JjFmb0WatM6JfdUaeXT9hrEEZgTDjwi9vc9wX/hP3R8vQ7pp ZlcUBwg5xxeGulc4hhg0H2hLZbLT6pyf4zBFtI0KIDMhsCX1yuBzN//Y7HKg2RY6 RnVOag4hh7tF+aefvYSoua/PZTES83xSvp1yDzM1stZ5EVp/f9LGTvfbqiHaV/KN N5evpVHYKm9FbDlgse0QGBZuzmoBQdABbrAK9NXcJCPwxaULXPvPrDUpddjgN1Fa wrsvXv0PzNzL1djwmBs0iw1x+Ef4OOQJOWBTwn6vRBZCdk6QCqtuOXVRvV8YYyYU WVG5fx+czo0N4alFoxR1NQwyz5HwedewSeYQdTrOqlm467h2Nh4KvBu5367+xYNo 9skmJQJcT+3gwJeKkOE3WbxXKBYSlsueg5A2JgPsksAhBImqQU8= =8uPB -----END PGP SIGNATURE----- --=-=-=--