summaryrefslogtreecommitdiff
path: root/guix/scripts
diff options
context:
space:
mode:
Diffstat (limited to 'guix/scripts')
-rw-r--r--guix/scripts/authenticate.scm192
-rw-r--r--guix/scripts/build.scm138
-rw-r--r--guix/scripts/environment.scm17
-rw-r--r--guix/scripts/import/hackage.scm2
-rw-r--r--guix/scripts/pack.scm39
-rw-r--r--guix/scripts/package.scm43
-rw-r--r--guix/scripts/repl.scm13
-rw-r--r--guix/scripts/system.scm116
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?