summaryrefslogtreecommitdiff
path: root/guix/scripts
diff options
context:
space:
mode:
Diffstat (limited to 'guix/scripts')
-rw-r--r--guix/scripts/authenticate.scm8
-rw-r--r--guix/scripts/build.scm222
-rw-r--r--guix/scripts/environment.scm17
-rw-r--r--guix/scripts/import/hackage.scm2
-rw-r--r--guix/scripts/offload.scm54
-rw-r--r--guix/scripts/pack.scm39
-rw-r--r--guix/scripts/package.scm43
-rw-r--r--guix/scripts/repl.scm13
-rwxr-xr-xguix/scripts/substitute.scm2
-rw-r--r--guix/scripts/system.scm118
-rw-r--r--guix/scripts/system/reconfigure.scm34
-rw-r--r--guix/scripts/upgrade.scm2
12 files changed, 409 insertions, 145 deletions
diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm
index 0bac13edee..45f62f6ebc 100644
--- a/guix/scripts/authenticate.scm
+++ b/guix/scripts/authenticate.scm
@@ -31,6 +31,7 @@
#:use-module (ice-9 rdelim)
#:use-module (ice-9 match)
#:use-module (ice-9 vlist)
+ #:use-module (ice-9 iconv)
#:export (guix-authenticate))
;;; Commentary:
@@ -122,8 +123,9 @@ by colon, followed by the given number of characters."
(reverse result))
(else
(let* ((len (string->number (read-delimited ":" port)))
- (str (utf8->string
- (get-bytevector-n port len))))
+ (str (bytevector->string
+ (get-bytevector-n port len)
+ "ISO-8859-1" 'error)))
(loop (cons str result))))))))))
(define-syntax define-enumerate-type ;TODO: factorize
@@ -150,7 +152,7 @@ by colon, followed by the given number of characters."
(define (send-reply code str)
;; Send CODE and STR as a reply to our client.
- (let ((bv (string->utf8 str)))
+ (let ((bv (string->bytevector str "ISO-8859-1" 'error)))
(format #t "~a ~a:" code (bytevector-length bv))
(put-bytevector (current-output-port) bv)
(force-output (current-output-port))))
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 25418661b9..e59e0ee67f 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -26,6 +26,7 @@
#:use-module (guix store)
#:use-module (guix derivations)
#:use-module (guix packages)
+ #:use-module (guix memoization)
#:use-module (guix grafts)
#:use-module (guix utils)
@@ -38,6 +39,7 @@
#:use-module (guix monads)
#:use-module (guix gexp)
#:use-module (guix profiles)
+ #:use-module (guix diagnostics)
#:autoload (guix http-client) (http-fetch http-get-error?)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
@@ -46,6 +48,7 @@
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
#:use-module (srfi srfi-37)
#:use-module (gnu packages)
#:autoload (guix download) (download-to-store)
@@ -61,6 +64,7 @@
%transformation-options
options->transformation
+ manifest-entry-with-transformations
show-transformation-options-help
guix-build
@@ -393,6 +397,102 @@ a checkout of the Git repository at the given URL."
(rewrite obj)
obj)))
+(define (package-dependents/spec top bottom)
+ "Return the list of dependents of BOTTOM, a spec string, that are also
+dependencies of TOP, a package."
+ (define-values (name version)
+ (package-name->name+version bottom))
+
+ (define dependent?
+ (mlambda (p)
+ (and (package? p)
+ (or (and (string=? name (package-name p))
+ (or (not version)
+ (version-prefix? version (package-version p))))
+ (match (bag-direct-inputs (package->bag p))
+ (((labels dependencies . _) ...)
+ (any dependent? dependencies)))))))
+
+ (filter dependent? (package-closure (list top))))
+
+(define (package-toolchain-rewriting p bottom toolchain)
+ "Return a procedure that, when passed a package that's either BOTTOM or one
+of its dependents up to P so, changes it so it is built with TOOLCHAIN.
+TOOLCHAIN must be an input list."
+ (define rewriting-property
+ (gensym " package-toolchain-rewriting"))
+
+ (match (package-dependents/spec p bottom)
+ (() ;P does not depend on BOTTOM
+ identity)
+ (set
+ ;; SET is the list of packages "between" P and BOTTOM (included) whose
+ ;; toolchain needs to be changed.
+ (package-mapping (lambda (p)
+ (if (or (assq rewriting-property
+ (package-properties p))
+ (not (memq p set)))
+ p
+ (let ((p (package-with-c-toolchain p toolchain)))
+ (package/inherit p
+ (properties `((,rewriting-property . #t)
+ ,@(package-properties p)))))))
+ (lambda (p)
+ (or (assq rewriting-property (package-properties p))
+ (not (memq p set))))
+ #:deep? #t))))
+
+(define (transform-package-toolchain replacement-specs)
+ "Return a procedure that, when passed a package, changes its toolchain or
+that of its dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is
+a list of strings like \"fftw=gcc-toolchain@10\" meaning that the package to
+the left of the equal sign must be built with the toolchain to the right of
+the equal sign."
+ (define split-on-commas
+ (cute string-tokenize <> (char-set-complement (char-set #\,))))
+
+ (define (specification->input spec)
+ (let ((package (specification->package spec)))
+ (list (package-name package) package)))
+
+ (define replacements
+ (map (lambda (spec)
+ (match (string-tokenize spec %not-equal)
+ ((spec (= split-on-commas toolchain))
+ (cons spec (map specification->input toolchain)))
+ (_
+ (leave (G_ "~a: invalid toolchain replacement specification~%")
+ spec))))
+ replacement-specs))
+
+ (lambda (store obj)
+ (if (package? obj)
+ (or (any (match-lambda
+ ((bottom . toolchain)
+ ((package-toolchain-rewriting obj bottom toolchain) obj)))
+ replacements)
+ obj)
+ obj)))
+
+(define (transform-package-tests specs)
+ "Return a procedure that, when passed a package, sets #:tests? #f in its
+'arguments' field."
+ (define (package-without-tests p)
+ (package/inherit p
+ (arguments
+ (substitute-keyword-arguments (package-arguments p)
+ ((#:tests? _ #f) #f)))))
+
+ (define rewrite
+ (package-input-rewriting/spec (map (lambda (spec)
+ (cons spec package-without-tests))
+ specs)))
+
+ (lambda (store obj)
+ (if (package? obj)
+ (rewrite obj)
+ obj)))
+
(define %transformations
;; Transformations that can be applied to things to build. The car is the
;; key used in the option alist, and the cdr is the transformation
@@ -403,7 +503,17 @@ a checkout of the Git repository at the given URL."
(with-graft . ,transform-package-inputs/graft)
(with-branch . ,transform-package-source-branch)
(with-commit . ,transform-package-source-commit)
- (with-git-url . ,transform-package-source-git-url)))
+ (with-git-url . ,transform-package-source-git-url)
+ (with-c-toolchain . ,transform-package-toolchain)
+ (without-tests . ,transform-package-tests)))
+
+(define (transformation-procedure key)
+ "Return the transformation procedure associated with KEY, a symbol such as
+'with-source', or #f if there is none."
+ (any (match-lambda
+ ((k . proc)
+ (and (eq? k key) proc)))
+ %transformations))
(define %transformation-options
;; The command-line interface to the above transformations.
@@ -423,11 +533,15 @@ a checkout of the Git repository at the given URL."
(option '("with-commit") #t #f
(parser 'with-commit))
(option '("with-git-url") #t #f
- (parser 'with-git-url)))))
+ (parser 'with-git-url))
+ (option '("with-c-toolchain") #t #f
+ (parser 'with-c-toolchain))
+ (option '("without-tests") #t #f
+ (parser 'without-tests)))))
(define (show-transformation-options-help)
(display (G_ "
- --with-source=SOURCE
+ --with-source=[PACKAGE=]SOURCE
use SOURCE when building the corresponding package"))
(display (G_ "
--with-input=PACKAGE=REPLACEMENT
@@ -443,7 +557,13 @@ a checkout of the Git repository at the given URL."
build PACKAGE from COMMIT"))
(display (G_ "
--with-git-url=PACKAGE=URL
- build PACKAGE from the repository at URL")))
+ build PACKAGE from the repository at URL"))
+ (display (G_ "
+ --with-c-toolchain=PACKAGE=TOOLCHAIN
+ build PACKAGE and its dependents with TOOLCHAIN"))
+ (display (G_ "
+ --without-tests=PACKAGE
+ build PACKAGE without running its tests")))
(define (options->transformation opts)
@@ -454,32 +574,69 @@ derivation, etc.), applies the transformations specified by OPTS."
;; order in which they appear on the command line.
(filter-map (match-lambda
((key . value)
- (match (any (match-lambda
- ((k . proc)
- (and (eq? k key) proc)))
- %transformations)
+ (match (transformation-procedure key)
(#f
#f)
(transform
;; XXX: We used to pass TRANSFORM a list of several
;; arguments, but we now pass only one, assuming that
;; transform composes well.
- (cons key (transform (list value)))))))
+ (list key value (transform (list value)))))))
(reverse opts)))
+ (define (package-with-transformation-properties p)
+ (package/inherit p
+ (properties `((transformations
+ . ,(map (match-lambda
+ ((key value _)
+ (cons key value)))
+ applicable))
+ ,@(package-properties p)))))
+
(lambda (store obj)
- (fold (match-lambda*
- (((name . transform) obj)
- (let ((new (transform store obj)))
- (when (eq? new obj)
- (warning (G_ "transformation '~a' had no effect on ~a~%")
- name
- (if (package? obj)
- (package-full-name obj)
- obj)))
- new)))
- obj
- applicable)))
+ (define (tagged-object new)
+ (if (and (not (eq? obj new))
+ (package? new) (not (null? applicable)))
+ (package-with-transformation-properties new)
+ new))
+
+ (tagged-object
+ (fold (match-lambda*
+ (((name value transform) obj)
+ (let ((new (transform store obj)))
+ (when (eq? new obj)
+ (warning (G_ "transformation '~a' had no effect on ~a~%")
+ name
+ (if (package? obj)
+ (package-full-name obj)
+ obj)))
+ new)))
+ obj
+ applicable))))
+
+(define (package-transformations package)
+ "Return the transformations applied to PACKAGE according to its properties."
+ (match (assq-ref (package-properties package) 'transformations)
+ (#f '())
+ (transformations transformations)))
+
+(define (manifest-entry-with-transformations entry)
+ "Return ENTRY with an additional 'transformations' property if it's not
+already there."
+ (let ((properties (manifest-entry-properties entry)))
+ (if (assq 'transformations properties)
+ entry
+ (let ((item (manifest-entry-item entry)))
+ (manifest-entry
+ (inherit entry)
+ (properties
+ (match (and (package? item)
+ (package-transformations item))
+ ((or #f '())
+ properties)
+ (transformations
+ `((transformations . ,transformations)
+ ,@properties)))))))))
;;;
@@ -805,7 +962,28 @@ must be one of 'package', 'all', or 'transitive'~%")
build---packages, gexps, derivations, and so on."
(define (validate-type x)
(unless (or (derivation? x) (file-like? x) (gexp? x) (procedure? x))
- (leave (G_ "~s: not something we can build~%") x)))
+ (raise (make-compound-condition
+ (formatted-message (G_ "~s: not something we can build~%") x)
+ (condition
+ (&fix-hint
+ (hint
+ (if (unspecified? x)
+ (G_ "If you build from a file, make sure the last Scheme
+expression returns a package value. @code{define-public} defines a variable,
+but returns @code{#<unspecified>}. To fix this, add a Scheme expression at
+the end of the file that consists only of the package's variable name you
+defined, as in this example:
+
+@example
+(define-public my-package
+ (package
+ ...))
+
+my-package
+@end example")
+ (G_ "If you build from a file, make sure the last
+Scheme expression returns a package, gexp, derivation or a list of such
+values.")))))))))
(define (ensure-list x)
(let ((lst (match x
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index ad50281eb2..085f11a9d4 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -34,6 +34,7 @@
#:use-module (guix scripts build)
#:use-module (gnu build linux-container)
#:use-module (gnu build accounts)
+ #:use-module ((guix build syscalls) #:select (set-network-interface-up))
#:use-module (gnu system linux-container)
#:use-module (gnu system file-systems)
#:use-module (gnu packages)
@@ -549,6 +550,16 @@ WHILE-LIST."
(write-passwd (list passwd))
(write-group groups)
+ (unless network?
+ ;; When isolated from the network, provide a minimal /etc/hosts
+ ;; to resolve "localhost".
+ (call-with-output-file "/etc/hosts"
+ (lambda (port)
+ (display "127.0.0.1 localhost\n" port)))
+
+ ;; Allow local AF_INET communications.
+ (set-network-interface-up "lo"))
+
;; For convenience, start in the user's current working
;; directory or, if unmapped, the home directory.
(chdir (if map-cwd?
@@ -564,7 +575,11 @@ WHILE-LIST."
(primitive-exit/status
;; A container's environment is already purified, so no need to
;; request it be purified again.
- (launch-environment command profile manifest #:pure? #f)))
+ (launch-environment command
+ (if link-profile?
+ (string-append home-dir "/.guix-profile")
+ profile)
+ manifest #:pure? #f)))
#:guest-uid uid
#:guest-gid gid
#:namespaces (if network?
diff --git a/guix/scripts/import/hackage.scm b/guix/scripts/import/hackage.scm
index 710e786a79..906dca24b1 100644
--- a/guix/scripts/import/hackage.scm
+++ b/guix/scripts/import/hackage.scm
@@ -49,7 +49,7 @@
Import and convert the Hackage package for PACKAGE-NAME. If PACKAGE-NAME
includes a suffix constituted by a at-sign followed by a numerical version (as
used with Guix packages), then a definition for the specified version of the
-package will be generated. If no version suffix is pecified, then the
+package will be generated. If no version suffix is specified, then the
generated package definition will correspond to the latest available
version.\n"))
(display (G_ "
diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index 3dc8ccefcb..a5fe98b675 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -88,6 +88,10 @@
(default 3))
(daemon-socket build-machine-daemon-socket ; string
(default "/var/guix/daemon-socket/socket"))
+ ;; A #f value tells the offload scheduler to disregard the load of the build
+ ;; machine when selecting the best offload machine.
+ (overload-threshold build-machine-overload-threshold ; inexact real between
+ (default 0.6)) ; 0.0 and 1.0 | #f
(parallel-builds build-machine-parallel-builds ; number
(default 1))
(speed build-machine-speed ; inexact real
@@ -391,30 +395,34 @@ of free disk space on '~a'~%")
(* 100 (expt 2 20))) ;100 MiB
(define (node-load node)
- "Return the load on NODE. Return +∞ if NODE is misbehaving."
+ "Return the load on NODE, a normalized value between 0.0 and 1.0. The value
+is derived from /proc/loadavg and normalized according to the number of
+logical cores available, to give a rough estimation of CPU usage. Return
+1.0 (fully loaded) if NODE is misbehaving."
(let ((line (inferior-eval '(begin
(use-modules (ice-9 rdelim))
(call-with-input-file "/proc/loadavg"
read-string))
- node)))
- (if (eof-object? line)
- +inf.0 ;MACHINE does not respond, so assume it is infinitely loaded
+ node))
+ (ncores (inferior-eval '(begin
+ (use-modules (ice-9 threads))
+ (current-processor-count))
+ node)))
+ (if (or (eof-object? line) (eof-object? ncores))
+ 1.0 ;MACHINE does not respond, so assume it is fully loaded
(match (string-tokenize line)
((one five fifteen . x)
- (string->number one))
+ (let ((load (/ (string->number one) ncores)))
+ (if (> load 1.0)
+ 1.0
+ load)))
(x
- +inf.0)))))
-
-(define (normalized-load machine load)
- "Divide LOAD by the number of parallel builds of MACHINE."
- (if (rational? load)
- (let* ((jobs (build-machine-parallel-builds machine))
- (normalized (/ load jobs)))
- (format (current-error-port) "load on machine '~a' is ~s\
- (normalized: ~s)~%"
- (build-machine-name machine) load normalized)
- normalized)
- load))
+ 1.0)))))
+
+(define (report-load machine load)
+ (format (current-error-port)
+ "normalized load on machine '~a' is ~,2f~%"
+ (build-machine-name machine) load))
(define (random-seed)
(logxor (getpid) (car (gettimeofday))))
@@ -472,11 +480,15 @@ slot (which must later be released with 'release-build-slot'), or #f and #f."
(let* ((session (false-if-exception (open-ssh-session best
%short-timeout)))
(node (and session (remote-inferior session)))
- (load (and node (normalized-load best (node-load node))))
+ (load (and node (node-load node)))
+ (threshold (build-machine-overload-threshold best))
(space (and node (node-free-disk-space node))))
+ (when load (report-load best load))
(when node (close-inferior node))
(when session (disconnect! session))
- (if (and node (< load 2.) (>= space %minimum-disk-space))
+ (if (and node
+ (or (not threshold) (< load threshold))
+ (>= space %minimum-disk-space))
(match others
(((machines slots) ...)
;; Release slots from the uninteresting machines.
@@ -708,13 +720,13 @@ machine."
(free (node-free-disk-space inferior)))
(close-inferior inferior)
(format #t "~a~% kernel: ~a ~a~% architecture: ~a~%\
- host name: ~a~% normalized load: ~a~% free disk space: ~,2f MiB~%\
+ host name: ~a~% normalized load: ~,2f~% free disk space: ~,2f MiB~%\
time difference: ~a s~%"
(build-machine-name machine)
(utsname:sysname uts) (utsname:release uts)
(utsname:machine uts)
(utsname:nodename uts)
- (normalized-load machine load)
+ load
(/ free (expt 2 20) 1.)
(- time now))))))))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index a0112162e3..ea2a96d5a1 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -826,11 +826,17 @@ last resort for relocation."
(string-append "-DLOADER_AUDIT_MODULE=\""
#$(audit-module) "\"")
+
+ ;; XXX: Normally (runpath #$(audit-module)) is
+ ;; enough. However, to work around
+ ;; <https://sourceware.org/bugzilla/show_bug.cgi?id=26634>
+ ;; (glibc <= 2.32), pass the whole search path of
+ ;; PROGRAM, which presumably is a superset of that
+ ;; of the audit module.
(string-append "-DLOADER_AUDIT_RUNPATH={ "
(string-join
(map object->string
- (runpath
- #$(audit-module)))
+ (runpath program))
", " 'suffix)
"NULL }")
(if gconv
@@ -1143,19 +1149,24 @@ Create a bundle of PACKAGE.\n"))
manifest))
identity))
+ (define (with-transformations manifest)
+ (map-manifest-entries manifest-entry-with-transformations
+ manifest))
+
(with-provenance
- (cond
- ((and (not (null? manifests)) (not (null? packages)))
- (leave (G_ "both a manifest and a package list were given~%")))
- ((not (null? manifests))
- (concatenate-manifests
- (map (lambda (file)
- (let ((user-module (make-user-module
- '((guix profiles) (gnu)))))
- (load* file user-module)))
- manifests)))
- (else
- (packages->manifest packages))))))
+ (with-transformations
+ (cond
+ ((and (not (null? manifests)) (not (null? packages)))
+ (leave (G_ "both a manifest and a package list were given~%")))
+ ((not (null? manifests))
+ (concatenate-manifests
+ (map (lambda (file)
+ (let ((user-module (make-user-module
+ '((guix profiles) (gnu)))))
+ (load* file user-module)))
+ manifests)))
+ (else
+ (packages->manifest packages)))))))
(with-error-handling
(with-store store
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 4eb968a49b..2f04652634 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -218,12 +218,13 @@ non-zero relevance score."
(output (manifest-entry-output old)))
transaction)))
- (define (upgrade entry)
+ (define (upgrade entry transform)
(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)))
+ (let* ((pkg (transform store pkg))
+ (candidate-version (package-version pkg)))
(match (package-superseded pkg)
((? package? new)
(supersede entry new))
@@ -231,12 +232,14 @@ non-zero relevance score."
(case (version-compare candidate-version version)
((>)
(manifest-transaction-install-entry
- (package->manifest-entry* pkg output)
+ (manifest-entry-with-transformations
+ (package->manifest-entry* pkg output))
transaction))
((<)
transaction)
((=)
- (let* ((new (package->manifest-entry* pkg output)))
+ (let* ((new (manifest-entry-with-transformations
+ (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
@@ -255,7 +258,14 @@ non-zero relevance score."
(if (manifest-transaction-removal-candidate? entry transaction)
transaction
- (upgrade entry)))
+
+ ;; Upgrade ENTRY, preserving transformation options listed in its
+ ;; properties.
+ (let ((transform (options->transformation
+ (or (assq-ref (manifest-entry-properties entry)
+ 'transformations)
+ '()))))
+ (upgrade entry transform))))
;;;
@@ -585,14 +595,8 @@ upgrading, #f otherwise."
(define (package->manifest-entry* package output)
"Like 'package->manifest-entry', but attach PACKAGE provenance meta-data to
the resulting manifest entry."
- (define (provenance-properties package)
- (match (package-provenance package)
- (#f '())
- (sexp `((provenance ,@sexp)))))
-
- (package->manifest-entry package output
- #:properties (provenance-properties package)))
-
+ (manifest-entry-with-provenance
+ (package->manifest-entry package output)))
(define (options->installable opts manifest transaction)
"Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold',
@@ -870,12 +874,13 @@ processed, #f otherwise."
(define (transform-entry entry)
(let ((item (transform store (manifest-entry-item entry))))
- (manifest-entry
- (inherit entry)
- (item item)
- (version (if (package? item)
- (package-version item)
- (manifest-entry-version entry))))))
+ (manifest-entry-with-transformations
+ (manifest-entry
+ (inherit entry)
+ (item item)
+ (version (if (package? item)
+ (package-version item)
+ (manifest-entry-version entry)))))))
(when (equal? profile %current-profile)
;; Normally the daemon created %CURRENT-PROFILE when we connected, unless
diff --git a/guix/scripts/repl.scm b/guix/scripts/repl.scm
index 3c79e89f8d..9f20803efc 100644
--- a/guix/scripts/repl.scm
+++ b/guix/scripts/repl.scm
@@ -27,6 +27,7 @@
#:use-module (srfi srfi-37)
#:use-module (ice-9 match)
#:use-module (rnrs bytevectors)
+ #:autoload (guix describe) (current-profile)
#:autoload (system repl repl) (start-repl)
#:autoload (system repl server)
(make-tcp-server-socket make-unix-domain-server-socket)
@@ -176,9 +177,19 @@ call THUNK."
;; Run script
(save-module-excursion
(lambda ()
+ ;; Invoke 'current-profile' so that it memoizes the correct value
+ ;; based on (program-arguments), before we call
+ ;; 'set-program-arguments'. This in turn ensures that
+ ;; (%package-module-path) will contain entries for the channels
+ ;; available in the current profile.
+ (current-profile)
+
(set-program-arguments script)
(set-user-module)
- (load-in-vicinity "." (car script)))))
+
+ ;; When passed a relative file name, 'load-in-vicinity' searches the
+ ;; file in %LOAD-PATH. Thus, pass (getcwd) instead of ".".
+ (load-in-vicinity (getcwd) (car script)))))
(when (null? script)
;; Start REPL
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 26613df68f..7ec170b08a 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -137,7 +137,7 @@ disabled!~%"))
(define %narinfo-negative-ttl
;; Likewise, but for negative lookups---i.e., cached lookup failures (404).
- (* 3 3600))
+ (* 1 3600))
(define %narinfo-transient-error-ttl
;; Likewise, but for transient errors such as 504 ("Gateway timeout").
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index bd5f84fc5b..9ed5c26483 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -384,6 +384,7 @@ STORE is an open connection to the store."
;; Make the specified system generation the default entry.
(params (first (profile-boot-parameters %system-profile
(list number))))
+ (locale (boot-parameters-locale params))
(old-generations
(delv number (reverse (generation-numbers %system-profile))))
(old-params (profile-boot-parameters
@@ -396,6 +397,7 @@ STORE is an open connection to the store."
((bootcfg (lower-object
((bootloader-configuration-file-generator bootloader)
bootloader-config entries
+ #:locale locale
#:old-entries old-entries)))
(drvs -> (list bootcfg)))
(mbegin %store-monad
@@ -666,38 +668,45 @@ checking this by themselves in their 'check' procedure."
;;; Action.
;;;
-(define* (system-derivation-for-action os base-image action
- #:key image-size file-system-type
+(define* (system-derivation-for-action os action
+ #:key image-size image-type
full-boot? container-shared-network?
mappings label)
"Return as a monadic value the derivation for OS according to ACTION."
- (case action
- ((build init reconfigure)
- (operating-system-derivation os))
- ((container)
- (container-script
- os
- #:mappings mappings
- #:shared-network? container-shared-network?))
- ((vm-image)
- (system-qemu-image os #:disk-image-size image-size))
- ((vm)
- (system-qemu-image/shared-store-script os
- #:full-boot? full-boot?
- #:disk-image-size
- (if full-boot?
- image-size
- (* 70 (expt 2 20)))
- #:mappings mappings))
- ((disk-image)
- (lower-object
- (system-image
- (image
- (inherit (if label (image-with-label base-image label) base-image))
- (size image-size)
- (operating-system os)))))
- ((docker-image)
- (system-docker-image os #:shared-network? container-shared-network?))))
+ (mlet %store-monad ((target (current-target-system)))
+ (case action
+ ((build init reconfigure)
+ (operating-system-derivation os))
+ ((container)
+ (container-script
+ os
+ #:mappings mappings
+ #:shared-network? container-shared-network?))
+ ((vm-image)
+ (system-qemu-image os #:disk-image-size image-size))
+ ((vm)
+ (system-qemu-image/shared-store-script os
+ #:full-boot? full-boot?
+ #:disk-image-size
+ (if full-boot?
+ image-size
+ (* 70 (expt 2 20)))
+ #:mappings mappings))
+ ((disk-image)
+ (let* ((base-image (os->image os #:type image-type))
+ (base-target (image-target base-image)))
+ (lower-object
+ (system-image
+ (image
+ (inherit (if label
+ (image-with-label base-image label)
+ base-image))
+ (target (or base-target target))
+ (size image-size)
+ (operating-system os))))))
+ ((docker-image)
+ (system-docker-image os
+ #:shared-network? container-shared-network?)))))
(define (maybe-suggest-running-guix-pull)
"Suggest running 'guix pull' if this has never been done before."
@@ -748,18 +757,19 @@ and TARGET arguments."
install-bootloader?
dry-run? derivations-only?
use-substitutes? bootloader-target target
- image-size file-system-type full-boot? label
- container-shared-network?
+ image-size image-type
+ full-boot? label container-shared-network?
(mappings '())
(gc-root #f))
"Perform ACTION for OS. INSTALL-BOOTLOADER? specifies whether to install
bootloader; BOOTLOADER-TAGET is the target for the bootloader; TARGET is the
target root directory; IMAGE-SIZE is the size of the image to be built, for
-the 'vm-image' and 'disk-image' actions. The root file system is created as a
-FILE-SYSTEM-TYPE file system. FULL-BOOT? is used for the 'vm' action; it
-determines whether to boot directly to the kernel or to the bootloader.
-CONTAINER-SHARED-NETWORK? determines if the container will use a separate
-network namespace.
+the 'vm-image' and 'disk-image' actions. IMAGE-TYPE is the type of image to
+be built.
+
+FULL-BOOT? is used for the 'vm' action; it determines whether to
+boot directly to the kernel or to the bootloader. CONTAINER-SHARED-NETWORK?
+determines if the container will use a separate network namespace.
When DERIVATIONS-ONLY? is true, print the derivation file name(s) without
building anything.
@@ -799,11 +809,9 @@ static checks."
(check-initrd-modules os)))
(mlet* %store-monad
- ((target* (current-target-system))
- (image -> (find-image file-system-type target*))
- (sys (system-derivation-for-action os image action
+ ((sys (system-derivation-for-action os action
#:label label
- #:file-system-type file-system-type
+ #:image-type image-type
#:image-size image-size
#:full-boot? full-boot?
#:container-shared-network? container-shared-network?
@@ -888,6 +896,17 @@ Run 'herd status' to view the list of services on your system.\n"))))))
;;;
+;;; Images.
+;;;
+
+(define (list-image-types)
+ "Print the available image types."
+ (display (G_ "The available image types are:\n"))
+ (newline)
+ (format #t "~{ - ~a ~%~}" (map image-type-name (force %image-types))))
+
+
+;;;
;;; Options.
;;;
@@ -945,9 +964,9 @@ Some ACTIONS support additional ARGS.\n"))
apply STRATEGY (one of nothing-special, backtrace,
or debug) when an error occurs while reading FILE"))
(display (G_ "
- --file-system-type=TYPE
- for 'disk-image', produce a root file system of TYPE
- (one of 'ext4', 'iso9660')"))
+ --list-image-types list available image types"))
+ (display (G_ "
+ -t, --image-type=TYPE for 'disk-image', produce an image of TYPE"))
(display (G_ "
--image-size=SIZE for 'vm-image', produce an image of SIZE"))
(display (G_ "
@@ -1008,10 +1027,14 @@ Some ACTIONS support additional ARGS.\n"))
(lambda (opt name arg result)
(alist-cons 'on-error (string->symbol arg)
result)))
- (option '(#\t "file-system-type") #t #f
+ (option '(#\t "image-type") #t #f
(lambda (opt name arg result)
- (alist-cons 'file-system-type arg
+ (alist-cons 'image-type (string->symbol arg)
result)))
+ (option '("list-image-types") #f #f
+ (lambda (opt name arg result)
+ (list-image-types)
+ (exit 0)))
(option '("image-size") #t #f
(lambda (opt name arg result)
(alist-cons 'image-size (size->number arg)
@@ -1080,7 +1103,7 @@ Some ACTIONS support additional ARGS.\n"))
(debug . 0)
(verbosity . #f) ;default
(validate-reconfigure . ,ensure-forward-reconfigure)
- (file-system-type . "ext4")
+ (image-type . raw)
(image-size . guess)
(install-bootloader? . #t)
(label . #f)))
@@ -1177,7 +1200,8 @@ resulting from command-line parsing."
(assoc-ref opts 'skip-safety-checks?)
#:validate-reconfigure
(assoc-ref opts 'validate-reconfigure)
- #:file-system-type (assoc-ref opts 'file-system-type)
+ #:image-type (lookup-image-type-by-name
+ (assoc-ref opts 'image-type))
#:image-size (assoc-ref opts 'image-size)
#:full-boot? (assoc-ref opts 'full-boot?)
#:container-shared-network?
diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm
index 45bb1d5d3b..d89caf80fc 100644
--- a/guix/scripts/system/reconfigure.scm
+++ b/guix/scripts/system/reconfigure.scm
@@ -126,22 +126,25 @@ return the <live-service> objects that are currently running on MACHINE."
(define exp
(with-imported-modules '((gnu services herd))
#~(begin
- (use-modules (gnu services herd))
+ (use-modules (gnu services herd)
+ (ice-9 match))
+
(let ((services (current-services)))
(and services
- ;; 'live-service-running' is ignored, as we can't necessarily
- ;; serialize arbitrary objects. This should be fine for now,
- ;; since 'machine-current-services' is not exposed publicly,
- ;; and the resultant <live-service> objects are only used for
- ;; resolving service dependencies.
(map (lambda (service)
(list (live-service-provision service)
- (live-service-requirement service)))
+ (live-service-requirement service)
+ (match (live-service-running service)
+ (#f #f)
+ (#t #t)
+ ((? number? pid) pid)
+ (_ #t)))) ;not serializable
services))))))
+
(mlet %store-monad ((services (eval exp)))
(return (map (match-lambda
- ((provision requirement)
- (live-service provision requirement #f)))
+ ((provision requirement running)
+ (live-service provision requirement running)))
services))))
;; XXX: Currently, this does NOT attempt to restart running services. See
@@ -181,13 +184,14 @@ services as defined by OS."
(mlet* %store-monad ((live-services (running-services eval)))
(let*-values (((to-unload to-restart)
(shepherd-service-upgrade live-services target-services)))
- (let* ((to-unload (map live-service-canonical-name to-unload))
+ (let* ((to-unload (map live-service-canonical-name to-unload))
(to-restart (map shepherd-service-canonical-name to-restart))
- (to-start (lset-difference eqv?
- (map shepherd-service-canonical-name
- target-services)
- (map live-service-canonical-name
- live-services)))
+ (running (map live-service-canonical-name
+ (filter live-service-running live-services)))
+ (to-start (lset-difference eqv?
+ (map shepherd-service-canonical-name
+ target-services)
+ running))
(service-files (map shepherd-service-file target-services)))
(eval #~(parameterize ((current-warning-port (%make-void-port "w")))
(primitive-load #$(upgrade-services-program service-files
diff --git a/guix/scripts/upgrade.scm b/guix/scripts/upgrade.scm
index 8c7abd133a..5ec844328e 100644
--- a/guix/scripts/upgrade.scm
+++ b/guix/scripts/upgrade.scm
@@ -36,6 +36,8 @@ This is an alias for 'guix package -u'.\n"))
-p, --profile=PROFILE use PROFILE instead of the user's default profile"))
(display (G_ "
-v, --verbosity=LEVEL use the given verbosity LEVEL"))
+ (display (G_ "
+ --do-not-upgrade[=REGEXP] do not upgrade any packages matching REGEXP"))
(newline)
(show-build-options-help)
(newline)