summaryrefslogtreecommitdiff
path: root/guix/scripts
diff options
context:
space:
mode:
authorMarius Bakke <mbakke@fastmail.com>2020-04-08 13:00:50 +0200
committerMarius Bakke <mbakke@fastmail.com>2020-04-08 13:00:50 +0200
commit27783023993f9272ce422868d14529159c4a5218 (patch)
tree9013b08aa39e497b1fd8e01a05254278d83f0ff7 /guix/scripts
parentbe1e842ad78ac6c52fc7790f4a3ffd716673c111 (diff)
parentba6f2bda18ed19fa486a9c3e2c3baea6c66c6867 (diff)
Merge branch 'master' into core-updates
Conflicts: etc/news.scm gnu/local.mk gnu/packages/check.scm gnu/packages/cross-base.scm gnu/packages/gimp.scm gnu/packages/java.scm gnu/packages/mail.scm gnu/packages/sdl.scm gnu/packages/texinfo.scm gnu/packages/tls.scm gnu/packages/version-control.scm
Diffstat (limited to 'guix/scripts')
-rw-r--r--guix/scripts/pack.scm1
-rw-r--r--guix/scripts/package.scm76
-rw-r--r--guix/scripts/system.scm32
-rw-r--r--guix/scripts/system/reconfigure.scm63
4 files changed, 95 insertions, 77 deletions
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index a4b38735a7..4f72304e57 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -1128,4 +1128,5 @@ to your package list.")))
gc-root))
(return (format #t "~a~%"
(derivation->output-path drv))))))
+ #:target target
#:system (assoc-ref opts 'system)))))))))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 304084796a..b2b734aadd 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -197,6 +197,10 @@ non-zero relevance score."
(define (transaction-upgrade-entry store entry transaction)
"Return a variant of TRANSACTION that accounts for the upgrade of ENTRY, a
<manifest-entry>."
+ (define (lower-manifest-entry* entry)
+ (run-with-store store
+ (lower-manifest-entry entry (%current-system))))
+
(define (supersede old new)
(info (G_ "package '~a' has been superseded by '~a'~%")
(manifest-entry-name old) (package-name new))
@@ -209,40 +213,44 @@ non-zero relevance score."
(output (manifest-entry-output old)))
transaction)))
- (match (if (manifest-transaction-removal-candidate? entry transaction)
- 'dismiss
- entry)
- ('dismiss
- transaction)
- (($ <manifest-entry> name version output (? string? path))
- (match (find-best-packages-by-name name #f)
- ((pkg . rest)
- (let ((candidate-version (package-version pkg)))
- (match (package-superseded pkg)
- ((? package? new)
- (supersede entry new))
- (#f
- (case (version-compare candidate-version version)
- ((>)
- (manifest-transaction-install-entry
- (package->manifest-entry* pkg output)
- transaction))
- ((<)
- transaction)
- ((=)
- (let ((candidate-path (derivation->output-path
- (package-derivation store pkg))))
- ;; XXX: When there are propagated inputs, assume we need to
- ;; upgrade the whole entry.
- (if (and (string=? path candidate-path)
- (null? (package-propagated-inputs pkg)))
- transaction
- (manifest-transaction-install-entry
- (package->manifest-entry* pkg output)
- transaction)))))))))
- (()
- (warning (G_ "package '~a' no longer exists~%") name)
- transaction)))))
+ (define (upgrade entry)
+ (match entry
+ (($ <manifest-entry> name version output (? string? path))
+ (match (find-best-packages-by-name name #f)
+ ((pkg . rest)
+ (let ((candidate-version (package-version pkg)))
+ (match (package-superseded pkg)
+ ((? package? new)
+ (supersede entry new))
+ (#f
+ (case (version-compare candidate-version version)
+ ((>)
+ (manifest-transaction-install-entry
+ (package->manifest-entry* pkg output)
+ transaction))
+ ((<)
+ transaction)
+ ((=)
+ (let* ((new (package->manifest-entry* pkg output)))
+ ;; Here we want to determine whether the NEW actually
+ ;; differs from ENTRY, but we need to intercept
+ ;; 'build-things' calls because they would prevent us from
+ ;; displaying the list of packages to install/upgrade
+ ;; upfront. Thus, if lowering NEW triggers a build (due
+ ;; to grafts), assume NEW differs from ENTRY.
+ (if (with-build-handler (const #f)
+ (manifest-entry=? (lower-manifest-entry* new)
+ entry))
+ transaction
+ (manifest-transaction-install-entry
+ new transaction)))))))))
+ (()
+ (warning (G_ "package '~a' no longer exists~%") name)
+ transaction)))))
+
+ (if (manifest-transaction-removal-candidate? entry transaction)
+ transaction
+ (upgrade entry)))
;;;
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index a178761203..2664c66a30 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -258,7 +258,7 @@ expression in %STORE-MONAD."
(lambda ()
(guard (c ((shepherd-error? c)
(values (report-shepherd-error c) store)))
- (values (run-with-store store (begin mbody ...))
+ (values (run-with-store store (mbegin %store-monad mbody ...))
store)))
(lambda (key proc format-string format-args errno . rest)
(warning (G_ "while talking to shepherd: ~a~%")
@@ -290,22 +290,6 @@ on service '~a':~%")
((not error) ;not an error
#t)))
-(define (call-with-service-upgrade-info new-services mproc)
- "Call MPROC, a monadic procedure in %STORE-MONAD, passing it the list of
-names of services to load (upgrade), and the list of names of services to
-unload."
- (match (current-services)
- ((services ...)
- (let-values (((to-unload to-restart)
- (shepherd-service-upgrade services new-services)))
- (mproc to-restart
- (map (compose first live-service-provision)
- to-unload))))
- (#f
- (with-monad %store-monad
- (warning (G_ "failed to obtain list of shepherd services~%"))
- (return #f)))))
-
(define-syntax-rule (unless-file-not-found exp)
(catch 'system-error
(lambda ()
@@ -825,10 +809,10 @@ static checks."
;; For 'init' and 'reconfigure', always build BOOTCFG, even if
;; --no-bootloader is passed, because we then use it as a GC root.
;; See <http://bugs.gnu.org/21068>.
- (drvs (mapm %store-monad lower-object
- (if (memq action '(init reconfigure))
- (list sys bootcfg)
- (list sys))))
+ (drvs (mapm/accumulate-builds lower-object
+ (if (memq action '(init reconfigure))
+ (list sys bootcfg)
+ (list sys))))
(% (if derivations-only?
(return (for-each (compose println derivation-file-name)
drvs))
@@ -853,7 +837,10 @@ static checks."
(info (G_ "bootloader successfully installed on '~a'~%")
(bootloader-configuration-target bootloader))))
(with-shepherd-error-handling
- (upgrade-shepherd-services local-eval os))))
+ (upgrade-shepherd-services local-eval os)
+ (return (format #t (G_ "\
+To complete the upgrade, run 'herd restart SERVICE' to stop,
+upgrade, and restart each service that was not automatically restarted.\n"))))))
((init)
(newline)
(format #t (G_ "initializing operating system under '~a'...~%")
@@ -1294,7 +1281,6 @@ argument list and OPTS is the option alist."
(process-command command args opts))))))
;;; Local Variables:
-;;; eval: (put 'call-with-service-upgrade-info 'scheme-indent-function 1)
;;; eval: (put 'with-store* 'scheme-indent-function 1)
;;; End:
diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm
index 77a72307b4..7885c33457 100644
--- a/guix/scripts/system/reconfigure.scm
+++ b/guix/scripts/system/reconfigure.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 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>
@@ -33,6 +33,7 @@
#:use-module (guix modules)
#:use-module (guix monads)
#:use-module (guix store)
+ #:use-module ((guix self) #:select (make-config.scm))
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
@@ -60,6 +61,14 @@
;;; Profile creation.
;;;
+(define not-config?
+ ;; Select (guix …) and (gnu …) modules, except (guix config).
+ (match-lambda
+ (('guix 'config) #f)
+ (('guix rest ...) #t)
+ (('gnu rest ...) #t)
+ (_ #f)))
+
(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
@@ -67,9 +76,11 @@ 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)))
+ (with-imported-modules `(,@(source-module-closure
+ '((guix profiles)
+ (guix utils))
+ #:select? not-config?)
+ ((guix config) => ,(make-config.scm)))
#~(begin
(use-modules (guix config)
(guix profiles)
@@ -89,7 +100,8 @@ atomically, and run OS's activation script."
"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))))
+ (eval #~(parameterize ((current-warning-port (%make-void-port "w")))
+ (primitive-load #$(switch-system-program os profile)))))
;;;
@@ -165,10 +177,11 @@ services as defined by OS."
(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)))))))
+ (eval #~(parameterize ((current-warning-port (%make-void-port "w")))
+ (primitive-load #$(upgrade-services-program service-files
+ to-start
+ to-unload
+ to-restart))))))))
;;;
@@ -184,10 +197,13 @@ 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)))
+ (with-imported-modules `(,@(source-module-closure
+ '((gnu build bootloader)
+ (gnu build install)
+ (guix store)
+ (guix utils))
+ #:select? not-config?)
+ ((guix config) => ,(make-config.scm)))
#~(begin
(use-modules (gnu build bootloader)
(gnu build install)
@@ -195,8 +211,10 @@ BOOTLOADER-PACKAGE."
(guix store)
(guix utils)
(ice-9 binary-ports)
+ (ice-9 match)
(srfi srfi-34)
(srfi srfi-35))
+
(let* ((gc-root (string-append #$target %gc-roots-directory "/bootcfg"))
(new-gc-root (string-append gc-root ".new")))
;; #$bootcfg has dependencies.
@@ -218,7 +236,11 @@ BOOTLOADER-PACKAGE."
(#$installer #$bootloader-package #$device #$target))
(lambda args
(delete-file new-gc-root)
- (apply throw args))))
+ (match args
+ (('%exception exception) ;Guile 3 SRFI-34 or similar
+ (raise-exception exception))
+ ((key . args)
+ (apply throw key args))))))
;; We are sure that the installation of the bootloader
;; succeeded, so we can replace the old GC root by the new
;; GC root now.
@@ -237,9 +259,10 @@ additional configurations specified by MENU-ENTRIES can be selected."
(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)))))
+ (eval #~(parameterize ((current-warning-port (%make-void-port "w")))
+ (primitive-load #$(install-bootloader-program installer
+ package
+ bootcfg
+ bootcfg-file
+ device
+ target))))))