Merge branch 'master' into staging

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?