diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/authenticate.scm | 192 | ||||
| -rw-r--r-- | guix/scripts/build.scm | 138 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 17 | ||||
| -rw-r--r-- | guix/scripts/import/hackage.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/pack.scm | 39 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 43 | ||||
| -rw-r--r-- | guix/scripts/repl.scm | 13 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 116 |
8 files changed, 414 insertions, 146 deletions
diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm index 37e6cef53c..45f62f6ebc 100644 --- a/guix/scripts/authenticate.scm +++ b/guix/scripts/authenticate.scm @@ -22,9 +22,16 @@ #:use-module (gcrypt pk-crypto) #:use-module (guix pki) #:use-module (guix ui) + #:use-module (guix diagnostics) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:use-module (srfi srfi-71) + #:use-module (rnrs bytevectors) #:use-module (ice-9 binary-ports) #:use-module (ice-9 rdelim) #:use-module (ice-9 match) + #:use-module (ice-9 vlist) + #:use-module (ice-9 iconv) #:export (guix-authenticate)) ;;; Commentary: @@ -39,42 +46,100 @@ ;; Read a gcrypt sexp from a port and return it. (compose string->canonical-sexp read-string)) -(define (sign-with-key key-file sha256) - "Sign the hash SHA256 (a bytevector) with KEY-FILE, and write an sexp that -includes both the hash and the actual signature." - (let* ((secret-key (call-with-input-file key-file read-canonical-sexp)) - (public-key (if (string-suffix? ".sec" key-file) - (call-with-input-file +(define (load-key-pair key-file) + "Load the key pair whose secret key lives at KEY-FILE. Return a pair of +canonical sexps representing those keys." + (catch 'system-error + (lambda () + (let* ((secret-key (call-with-input-file key-file read-canonical-sexp)) + (public-key (call-with-input-file (string-append (string-drop-right key-file 4) ".pub") - read-canonical-sexp) - (leave - (G_ "cannot find public key for secret key '~a'~%") - key-file))) - (data (bytevector->hash-data sha256 - #:key-type (key-type public-key))) - (signature (signature-sexp data secret-key public-key))) - (display (canonical-sexp->string signature)) - #t)) - -(define (validate-signature signature) + read-canonical-sexp))) + (cons public-key secret-key))) + (lambda args + (let ((errno (system-error-errno args))) + (raise + (formatted-message + (G_ "failed to load key pair at '~a': ~a~%") + key-file (strerror errno))))))) + +(define (sign-with-key public-key secret-key sha256) + "Sign the hash SHA256 (a bytevector) with SECRET-KEY (a canonical sexp), and +return the signature as a canonical sexp that includes SHA256, PUBLIC-KEY, and +the actual signature." + (let ((data (bytevector->hash-data sha256 + #:key-type (key-type public-key)))) + (signature-sexp data secret-key public-key))) + +(define (validate-signature signature acl) "Validate SIGNATURE, a canonical sexp. Check whether its public key is -authorized, verify the signature, and print the signed data to stdout upon -success." +authorized in ACL, verify the signature, and return the signed data (a +bytevector) upon success." (let* ((subject (signature-subject signature)) (data (signature-signed-data signature))) (if (and data subject) - (if (authorized-key? subject) + (if (authorized-key? subject acl) (if (valid-signature? signature) - (let ((hash (hash-data->bytevector data))) - (display (bytevector->base16-string hash)) - #t) ; success - (leave (G_ "error: invalid signature: ~a~%") - (canonical-sexp->string signature))) - (leave (G_ "error: unauthorized public key: ~a~%") - (canonical-sexp->string subject))) - (leave (G_ "error: corrupt signature data: ~a~%") - (canonical-sexp->string signature))))) + (hash-data->bytevector data) ; success + (raise + (formatted-message (G_ "invalid signature: ~a") + (canonical-sexp->string signature)))) + (raise + (formatted-message (G_ "unauthorized public key: ~a") + (canonical-sexp->string subject)))) + (raise + (formatted-message (G_ "corrupt signature data: ~a") + (canonical-sexp->string signature)))))) + +(define (read-command port) + "Read a command from PORT and return the command and arguments as a list of +strings. Return the empty list when the end-of-file is reached. + +Commands are newline-terminated and must look something like this: + + COMMAND 3:abc 5:abcde 1:x + +where COMMAND is an alphanumeric sequence and the remainder is the command +arguments. Each argument is written as its length (in characters), followed +by colon, followed by the given number of characters." + (define (consume-whitespace port) + (let ((chr (lookahead-u8 port))) + (when (eqv? chr (char->integer #\space)) + (get-u8 port) + (consume-whitespace port)))) + + (match (read-delimited " \t\n\r" port) + ((? eof-object?) + '()) + (command + (let loop ((result (list command))) + (consume-whitespace port) + (let ((next (lookahead-u8 port))) + (cond ((eqv? next (char->integer #\newline)) + (get-u8 port) + (reverse result)) + ((eof-object? next) + (reverse result)) + (else + (let* ((len (string->number (read-delimited ":" port))) + (str (bytevector->string + (get-bytevector-n port len) + "ISO-8859-1" 'error))) + (loop (cons str result)))))))))) + +(define-syntax define-enumerate-type ;TODO: factorize + (syntax-rules () + ((_ name->int (name id) ...) + (define-syntax name->int + (syntax-rules (name ...) + ((_ name) id) ...))))) + +;; Codes used when reply to requests. +(define-enumerate-type reply-code + (success 0) + (command-not-found 404) + (command-failed 500)) ;;; @@ -85,6 +150,26 @@ success." (category internal) (synopsis "sign or verify signatures on normalized archives (nars)") + (define (send-reply code str) + ;; Send CODE and STR as a reply to our client. + (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)))) + + (define (call-with-reply thunk) + ;; Send a reply for the result of THUNK or for any exception raised during + ;; its execution. + (guard (c ((formatted-message? c) + (send-reply (reply-code command-failed) + (apply format #f + (G_ (formatted-message-string c)) + (formatted-message-arguments c))))) + (send-reply (reply-code success) (thunk)))) + + (define-syntax-rule (with-reply exp ...) + (call-with-reply (lambda () exp ...))) + ;; Signature sexps written to stdout may contain binary data, so force ;; ISO-8859-1 encoding so that things are not mangled. See ;; <http://bugs.gnu.org/17312> for details. @@ -95,21 +180,46 @@ success." (with-fluids ((%default-port-encoding "ISO-8859-1") (%default-port-conversion-strategy 'error)) (match args - (("sign" key-file hash) - (sign-with-key key-file (base16-string->bytevector hash))) - (("verify" signature-file) - (call-with-input-file signature-file - (lambda (port) - (validate-signature (string->canonical-sexp - (read-string port)))))) - (("--help") (display (G_ "Usage: guix authenticate OPTION... -Sign or verify the signature on the given file. This tool is meant to -be used internally by 'guix-daemon'.\n"))) +Sign data or verify signatures. This tool is meant to be used internally by +'guix-daemon'.\n"))) (("--version") (show-version-and-exit "guix authenticate")) - (else - (leave (G_ "wrong arguments")))))) + (() + (let ((acl (current-acl))) + (let loop ((key-pairs vlist-null)) + ;; Read a request on standard input and reply. + (match (read-command (current-input-port)) + (("sign" signing-key (= base16-string->bytevector hash)) + (let* ((key-pairs keys + (match (vhash-assoc signing-key key-pairs) + ((_ . keys) + (values key-pairs keys)) + (#f + (let ((keys (load-key-pair signing-key))) + (values (vhash-cons signing-key keys + key-pairs) + keys)))))) + (with-reply (canonical-sexp->string + (match keys + ((public . secret) + (sign-with-key public secret hash))))) + (loop key-pairs))) + (("verify" signature) + (with-reply (bytevector->base16-string + (validate-signature + (string->canonical-sexp signature) + acl))) + (loop key-pairs)) + (() + (exit 0)) + (commands + (warning (G_ "~s: invalid command; ignoring~%") commands) + (send-reply (reply-code command-not-found) + "invalid command") + (loop key-pairs)))))) + (_ + (leave (G_ "wrong arguments~%")))))) ;;; authenticate.scm ends here diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 25418661b9..72a5d46347 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -38,6 +38,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 +47,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 +63,7 @@ %transformation-options options->transformation + manifest-entry-with-transformations show-transformation-options-help guix-build @@ -393,6 +396,25 @@ a checkout of the Git repository at the given URL." (rewrite 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 +425,16 @@ 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) + (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 +454,13 @@ 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 '("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 +476,10 @@ 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_ " + --without-tests=PACKAGE + build PACKAGE without running its tests"))) (define (options->transformation opts) @@ -454,32 +490,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 +878,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/pack.scm b/guix/scripts/pack.scm index 379e6a3ac6..0b66da01f9 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -817,11 +817,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 @@ -1134,19 +1140,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/system.scm b/guix/scripts/system.scm index bd5f84fc5b..939559e719 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -666,38 +666,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 +755,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 +807,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 +894,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 +962,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 +1025,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 +1101,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 +1198,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? |