diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/authenticate.scm | 8 | ||||
| -rw-r--r-- | guix/scripts/build.scm | 222 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 17 | ||||
| -rw-r--r-- | guix/scripts/import/hackage.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/offload.scm | 54 | ||||
| -rw-r--r-- | guix/scripts/pack.scm | 39 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 43 | ||||
| -rw-r--r-- | guix/scripts/repl.scm | 13 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 118 | ||||
| -rw-r--r-- | guix/scripts/system/reconfigure.scm | 34 | ||||
| -rw-r--r-- | guix/scripts/upgrade.scm | 2 |
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) |