~ruther/guix-local

4ee96a7912eef8c41c855c680f924dcdba2d9c97 — Ludovic Courtès 9 years ago 0bb9929
gnu: Switch to 'with-imported-modules'.

* gnu/services.scm (directory-union): Use 'with-imported-modules'
instead of the '#:modules' argument of 'computed-file'.
* gnu/services/base.scm (udev-rules-union): Likewise.
* gnu/services/dbus.scm (system-service-directory): Likewise.
* gnu/services/desktop.scm (wrapped-dbus-service):
(polkit-directory): Likewise.
* gnu/services/networking.scm (tor-configuration->torrc): Likewise.
* gnu/services/xorg.scm (xorg-configuration-directory): Likewise.
* gnu/system/install.scm (self-contained-tarball): Likewise.
* gnu/system/linux-container.scm (container-script): Likewise.
* gnu/system/linux-initrd.scm (expression->initrd): Likewise, and
remove #:modules parameter.
(flat-linux-module-directory): Use 'with-imported-modules'.
(base-initrd): Likewise.
* gnu/system/locale.scm (locale-directory): Likewise.
* gnu/system/shadow.scm (default-skeletons): Likewise.
* gnu/system/vm.scm (expression->derivation-in-linux-vm): Likewise.
* gnu/tests/base.scm (run-basic-test): Likewise.
* gnu/tests/install.scm (run-install): Likewise.
* doc/guix.texi (Initial RAM Disk): Update 'expression->initrd'
documentation.
M doc/guix.texi => doc/guix.texi +1 -5
@@ 10016,15 10016,11 @@ program.  That gives a lot of flexibility.  The
program to run in that initrd.

@deffn {Monadic Procedure} expression->initrd @var{exp} @
       [#:guile %guile-static-stripped] [#:name "guile-initrd"] @
       [#:modules '()]
       [#:guile %guile-static-stripped] [#:name "guile-initrd"]
Return a derivation that builds a Linux initrd (a gzipped cpio archive)
containing @var{guile} and that evaluates @var{exp}, a G-expression,
upon booting.  All the derivations referenced by @var{exp} are
automatically copied to the initrd.

@var{modules} is a list of Guile module names to be embedded in the
initrd.
@end deffn

@node GRUB Configuration

M gnu/services.scm => gnu/services.scm +4 -4
@@ 309,10 309,10 @@ file."
     one)
    (_
     (computed-file name
                    #~(begin
                        (use-modules (guix build union))
                        (union-build #$output '#$things))
                    #:modules '((guix build union))))))
                    (with-imported-modules '((guix build union))
                      #~(begin
                          (use-modules (guix build union))
                          (union-build #$output '#$things)))))))

(define* (activation-service->script service)
  "Return as a monadic value the activation script for SERVICE, a service of

M gnu/services/base.scm => gnu/services/base.scm +30 -30
@@ 1138,44 1138,44 @@ archive}).  If that is not the case, the service will fail to start."
  "Return the union of the @code{lib/udev/rules.d} directories found in each
item of @var{packages}."
  (define build
    #~(begin
        (use-modules (guix build union)
                     (guix build utils)
                     (srfi srfi-1)
                     (srfi srfi-26))
    (with-imported-modules '((guix build union)
                             (guix build utils))
      #~(begin
          (use-modules (guix build union)
                       (guix build utils)
                       (srfi srfi-1)
                       (srfi srfi-26))

        (define %standard-locations
          '("/lib/udev/rules.d" "/libexec/udev/rules.d"))
          (define %standard-locations
            '("/lib/udev/rules.d" "/libexec/udev/rules.d"))

        (define (rules-sub-directory directory)
          ;; Return the sub-directory of DIRECTORY containing udev rules, or
          ;; #f if none was found.
          (find directory-exists?
                (map (cut string-append directory <>) %standard-locations)))
          (define (rules-sub-directory directory)
            ;; Return the sub-directory of DIRECTORY containing udev rules, or
            ;; #f if none was found.
            (find directory-exists?
                  (map (cut string-append directory <>) %standard-locations)))

        (mkdir-p (string-append #$output "/lib/udev"))
        (union-build (string-append #$output "/lib/udev/rules.d")
                     (filter-map rules-sub-directory '#$packages))))
          (mkdir-p (string-append #$output "/lib/udev"))
          (union-build (string-append #$output "/lib/udev/rules.d")
                       (filter-map rules-sub-directory '#$packages)))))

  (computed-file "udev-rules" build
                 #:modules '((guix build union)
                             (guix build utils))))
  (computed-file "udev-rules" build))

(define (udev-rule file-name contents)
  "Return a directory with a udev rule file FILE-NAME containing CONTENTS."
  (computed-file file-name
                 #~(begin
                     (use-modules (guix build utils))

                     (define rules.d
                       (string-append #$output "/lib/udev/rules.d"))

                     (mkdir-p rules.d)
                     (call-with-output-file
                         (string-append rules.d "/" #$file-name)
                       (lambda (port)
                         (display #$contents port))))
                 #:modules '((guix build utils))))
                 (with-imported-modules '((guix build utils))
                   #~(begin
                       (use-modules (guix build utils))

                       (define rules.d
                         (string-append #$output "/lib/udev/rules.d"))

                       (mkdir-p rules.d)
                       (call-with-output-file
                           (string-append rules.d "/" #$file-name)
                         (lambda (port)
                           (display #$contents port)))))))

(define kvm-udev-rule
  ;; Return a directory with a udev rule that changes the group of /dev/kvm to

M gnu/services/dbus.scm => gnu/services/dbus.scm +21 -20
@@ 46,26 46,27 @@
  "Return the system service directory, containing @code{.service} files for
all the services that may be activated by the daemon."
  (computed-file "dbus-system-services"
                 #~(begin
                     (use-modules (guix build utils)
                                  (srfi srfi-1))

                     (define files
                       (append-map (lambda (service)
                                     (find-files (string-append
                                                  service
                                                  "/share/dbus-1/system-services")
                                                 "\\.service$"))
                                   (list #$@services)))

                     (mkdir #$output)
                     (for-each (lambda (file)
                                 (symlink file
                                          (string-append #$output "/"
                                                         (basename file))))
                               files)
                     #t)
                 #:modules '((guix build utils))))
                 (with-imported-modules '((guix build utils))
                   #~(begin
                       (use-modules (guix build utils)
                                    (srfi srfi-1))

                       (define files
                         (append-map (lambda (service)
                                       (find-files
                                        (string-append
                                         service
                                         "/share/dbus-1/system-services")
                                        "\\.service$"))
                                     (list #$@services)))

                       (mkdir #$output)
                       (for-each (lambda (file)
                                   (symlink file
                                            (string-append #$output "/"
                                                           (basename file))))
                                 files)
                       #t))))

(define (dbus-configuration-directory services)
  "Return a directory contains the @code{system-local.conf} file for DBUS that

M gnu/services/desktop.scm => gnu/services/desktop.scm +35 -32
@@ 91,30 91,33 @@ is set to @var{value} when the bus daemon launches it."
                             (string-append #$service "/" #$program)
                             (cdr (command-line))))))

  (define build
    (with-imported-modules '((guix build utils))
      #~(begin
          (use-modules (guix build utils))

          (define service-directory
            "/share/dbus-1/system-services")

          (mkdir-p (dirname (string-append #$output
                                           service-directory)))
          (copy-recursively (string-append #$service
                                           service-directory)
                            (string-append #$output
                                           service-directory))
          (symlink (string-append #$service "/etc") ;for etc/dbus-1
                   (string-append #$output "/etc"))

          (for-each (lambda (file)
                      (substitute* file
                        (("Exec[[:blank:]]*=[[:blank:]]*([[:graph:]]+)(.*)$"
                          _ original-program arguments)
                         (string-append "Exec=" #$wrapper arguments
                                        "\n"))))
                    (find-files #$output "\\.service$")))))

  (computed-file (string-append (package-name service) "-wrapper")
                 #~(begin
                     (use-modules (guix build utils))

                     (define service-directory
                       "/share/dbus-1/system-services")

                     (mkdir-p (dirname (string-append #$output
                                                      service-directory)))
                     (copy-recursively (string-append #$service
                                                      service-directory)
                                       (string-append #$output
                                                      service-directory))
                     (symlink (string-append #$service "/etc") ;for etc/dbus-1
                              (string-append #$output "/etc"))

                     (for-each (lambda (file)
                                 (substitute* file
                                   (("Exec[[:blank:]]*=[[:blank:]]*([[:graph:]]+)(.*)$"
                                     _ original-program arguments)
                                    (string-append "Exec=" #$wrapper arguments
                                                   "\n"))))
                               (find-files #$output "\\.service$")))
                 #:modules '((guix build utils))))
                 build))


;;;


@@ 408,15 411,15 @@ Users need to be in the @code{lp} group to access the D-Bus service.
(define (polkit-directory packages)
  "Return a directory containing an @file{actions} and possibly a
@file{rules.d} sub-directory, for use as @file{/etc/polkit-1}."
  (computed-file "etc-polkit-1"
                 #~(begin
                     (use-modules (guix build union) (srfi srfi-26))

                     (union-build #$output
                                  (map (cut string-append <>
                                            "/share/polkit-1")
                                       (list #$@packages))))
                 #:modules '((guix build union))))
  (with-imported-modules '((guix build union))
    (computed-file "etc-polkit-1"
                   #~(begin
                       (use-modules (guix build union) (srfi srfi-26))

                       (union-build #$output
                                    (map (cut string-append <>
                                              "/share/polkit-1")
                                         (list #$@packages)))))))

(define polkit-etc-files
  (match-lambda

M gnu/services/networking.scm => gnu/services/networking.scm +27 -27
@@ 1,5 1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;;


@@ 345,39 345,39 @@ keep the system clock synchronized with that of @var{servers}."
    (($ <tor-configuration> tor config-file services)
     (computed-file
      "torrc"
      #~(begin
          (use-modules (guix build utils)
                       (ice-9 match))

          (call-with-output-file #$output
            (lambda (port)
              (display "\
      (with-imported-modules '((guix build utils))
        #~(begin
            (use-modules (guix build utils)
                         (ice-9 match))

            (call-with-output-file #$output
              (lambda (port)
                (display "\
# The beginning was automatically added.
User tor
DataDirectory /var/lib/tor
Log notice syslog\n" port)

              (for-each (match-lambda
                          ((service (ports hosts) ...)
                           (format port "\
                (for-each (match-lambda
                            ((service (ports hosts) ...)
                             (format port "\
HiddenServiceDir /var/lib/tor/hidden-services/~a~%"
                                   service)
                           (for-each (lambda (tcp-port host)
                                       (format port "\
                                     service)
                             (for-each (lambda (tcp-port host)
                                         (format port "\
HiddenServicePort ~a ~a~%"
                                               tcp-port host))
                                     ports hosts)))
                        '#$(map (match-lambda
                                  (($ <hidden-service> name mapping)
                                   (cons name mapping)))
                                services))

              ;; Append the user's config file.
              (call-with-input-file #$config-file
                (lambda (input)
                  (dump-port input port)))
              #t)))
      #:modules '((guix build utils))))))
                                                 tcp-port host))
                                       ports hosts)))
                          '#$(map (match-lambda
                                    (($ <hidden-service> name mapping)
                                     (cons name mapping)))
                                  services))

                ;; Append the user's config file.
                (call-with-input-file #$config-file
                  (lambda (input)
                    (dump-port input port)))
                #t))))))))

(define (tor-shepherd-service config)
  "Return a <shepherd-service> running TOR."

M gnu/services/xorg.scm => gnu/services/xorg.scm +21 -21
@@ 158,27 158,27 @@ EndSection
  "Return a directory that contains the @code{.conf} files for X.org that
includes the @code{share/X11/xorg.conf.d} directories of each package listed
in @var{modules}."
  (computed-file "xorg.conf.d"
                 #~(begin
                     (use-modules (guix build utils)
                                  (srfi srfi-1))

                     (define files
                       (append-map (lambda (module)
                                     (find-files (string-append
                                                  module
                                                  "/share/X11/xorg.conf.d")
                                                 "\\.conf$"))
                                   (list #$@modules)))

                     (mkdir #$output)
                     (for-each (lambda (file)
                                 (symlink file
                                          (string-append #$output "/"
                                                         (basename file))))
                               files)
                     #t)
                 #:modules '((guix build utils))))
  (with-imported-modules '((guix build utils))
    (computed-file "xorg.conf.d"
                   #~(begin
                       (use-modules (guix build utils)
                                    (srfi srfi-1))

                       (define files
                         (append-map (lambda (module)
                                       (find-files (string-append
                                                    module
                                                    "/share/X11/xorg.conf.d")
                                                   "\\.conf$"))
                                     (list #$@modules)))

                       (mkdir #$output)
                       (for-each (lambda (file)
                                   (symlink file
                                            (string-append #$output "/"
                                                           (basename file))))
                                 files)
                       #t))))

(define* (xorg-start-command #:key
                             (guile (canonical-package guile-2.0))

M gnu/system/install.scm => gnu/system/install.scm +59 -58
@@ 55,52 55,53 @@ under /root/.guix-profile where GUIX is installed."
                                (manifest
                                 (list (package->manifest-entry guix))))))
    (define build
      #~(begin
          (use-modules (guix build utils)
                       (gnu build install))

          (define %root "root")

          (setenv "PATH"
                  (string-append #$guix "/sbin:" #$tar "/bin:" #$xz "/bin"))

          ;; Note: there is not much to gain here with deduplication and there
          ;; is the overhead of the '.links' directory, so turn it off.
          (populate-single-profile-directory %root
                                             #:profile #$profile
                                             #:closure "profile"
                                             #:deduplicate? #f)

          ;; Create the tarball.  Use GNU format so there's no file name
          ;; length limitation.
          (with-directory-excursion %root
            (zero? (system* "tar" "--xz" "--format=gnu"

                            ;; Avoid non-determinism in the archive.  Use
                            ;; mtime = 1, not zero, because that is what the
                            ;; daemon does for files in the store (see the
                            ;; 'mtimeStore' constant in local-store.cc.)
                            "--sort=name"
                            "--mtime=@1"          ;for files in /var/guix
                            "--owner=root:0"
                            "--group=root:0"

                            "--check-links"
                            "-cvf" #$output
                            ;; Avoid adding / and /var to the tarball,
                            ;; so that the ownership and permissions of those
                            ;; directories will not be overwritten when
                            ;; extracting the archive.  Do not include /root
                            ;; because the root account might have a different
                            ;; home directory.
                            "./var/guix"
                            (string-append "." (%store-directory)))))))
      (with-imported-modules '((guix build utils)
                               (guix build store-copy)
                               (gnu build install))
        #~(begin
            (use-modules (guix build utils)
                         (gnu build install))

            (define %root "root")

            (setenv "PATH"
                    (string-append #$guix "/sbin:" #$tar "/bin:" #$xz "/bin"))

            ;; Note: there is not much to gain here with deduplication and
            ;; there is the overhead of the '.links' directory, so turn it
            ;; off.
            (populate-single-profile-directory %root
                                               #:profile #$profile
                                               #:closure "profile"
                                               #:deduplicate? #f)

            ;; Create the tarball.  Use GNU format so there's no file name
            ;; length limitation.
            (with-directory-excursion %root
              (zero? (system* "tar" "--xz" "--format=gnu"

                              ;; Avoid non-determinism in the archive.  Use
                              ;; mtime = 1, not zero, because that is what the
                              ;; daemon does for files in the store (see the
                              ;; 'mtimeStore' constant in local-store.cc.)
                              "--sort=name"
                              "--mtime=@1"        ;for files in /var/guix
                              "--owner=root:0"
                              "--group=root:0"

                              "--check-links"
                              "-cvf" #$output
                              ;; Avoid adding / and /var to the tarball, so
                              ;; that the ownership and permissions of those
                              ;; directories will not be overwritten when
                              ;; extracting the archive.  Do not include /root
                              ;; because the root account might have a
                              ;; different home directory.
                              "./var/guix"
                              (string-append "." (%store-directory))))))))

    (gexp->derivation "guix-tarball.tar.xz" build
                      #:references-graphs `(("profile" ,profile))
                      #:modules '((guix build utils)
                                  (guix build store-copy)
                                  (gnu build install)))))
                      #:references-graphs `(("profile" ,profile)))))


(define (log-to-info)


@@ 212,20 213,20 @@ the user's target storage device rather than on the RAM disk."

  (define directory
    (computed-file "configuration-templates"
                   #~(begin
                       (mkdir #$output)
                       (for-each (lambda (file target)
                                   (copy-file file
                                              (string-append #$output "/"
                                                             target)))
                                 '(#$(file "bare-bones.tmpl")
                                   #$(file "desktop.tmpl")
                                   #$(file "lightweight-desktop.tmpl"))
                                 '("bare-bones.scm"
                                   "desktop.scm"
                                   "lightweight-desktop.scm"))
                       #t)
                   #:modules '((guix build utils))))
                   (with-imported-modules '((guix build utils))
                     #~(begin
                         (mkdir #$output)
                         (for-each (lambda (file target)
                                     (copy-file file
                                                (string-append #$output "/"
                                                               target)))
                                   '(#$(file "bare-bones.tmpl")
                                     #$(file "desktop.tmpl")
                                     #$(file "lightweight-desktop.tmpl"))
                                   '("bare-bones.scm"
                                     "desktop.scm"
                                     "lightweight-desktop.scm"))
                         #t))))

  `(("configuration" ,directory)))


M gnu/system/linux-container.scm => gnu/system/linux-container.scm +23 -25
@@ 87,30 87,28 @@ that will be shared with the host system."
                                  #:container? #t)))

      (define script
        #~(begin
            (use-modules (gnu build linux-container)
                         (guix build utils))
        (with-imported-modules '((guix config)
                                 (guix utils)
                                 (guix build utils)
                                 (guix build syscalls)
                                 (guix build bournish)
                                 (gnu build file-systems)
                                 (gnu build linux-container))
          #~(begin
              (use-modules (gnu build linux-container)
                           (guix build utils))

            (call-with-container '#$specs
              (lambda ()
                (setenv "HOME" "/root")
                (setenv "TMPDIR" "/tmp")
                (setenv "GUIX_NEW_SYSTEM" #$os-drv)
                (for-each mkdir-p '("/run" "/bin" "/etc" "/home" "/var"))
                (primitive-load (string-append #$os-drv "/boot")))
              ;; A range of 65536 uid/gids is used to cover 16 bits worth of
              ;; users and groups, which is sufficient for most cases.
              ;;
              ;; See: http://www.freedesktop.org/software/systemd/man/systemd-nspawn.html#--private-users=
              #:host-uids 65536)))
              (call-with-container '#$specs
                (lambda ()
                  (setenv "HOME" "/root")
                  (setenv "TMPDIR" "/tmp")
                  (setenv "GUIX_NEW_SYSTEM" #$os-drv)
                  (for-each mkdir-p '("/run" "/bin" "/etc" "/home" "/var"))
                  (primitive-load (string-append #$os-drv "/boot")))
                ;; A range of 65536 uid/gids is used to cover 16 bits worth of
                ;; users and groups, which is sufficient for most cases.
                ;;
                ;; See: http://www.freedesktop.org/software/systemd/man/systemd-nspawn.html#--private-users=
                #:host-uids 65536))))

      (gexp->script "run-container" script
                    #:modules '((ice-9 match)
                                (srfi srfi-98)
                                (guix config)
                                (guix utils)
                                (guix build utils)
                                (guix build syscalls)
                                (guix build bournish)
                                (gnu build file-systems)
                                (gnu build linux-container))))))
      (gexp->script "run-container" script))))

M gnu/system/linux-initrd.scm => gnu/system/linux-initrd.scm +83 -87
@@ 55,85 55,81 @@
                             (guile %guile-static-stripped)
                             (gzip gzip)
                             (name "guile-initrd")
                             (system (%current-system))
                             (modules '()))
                             (system (%current-system)))
  "Return a derivation that builds a Linux initrd (a gzipped cpio archive)
containing GUILE and that evaluates EXP, a G-expression, upon booting.  All
the derivations referenced by EXP are automatically copied to the initrd.

MODULES is a list of Guile module names to be embedded in the initrd."
the derivations referenced by EXP are automatically copied to the initrd."

  ;; General Linux overview in `Documentation/early-userspace/README' and
  ;; `Documentation/filesystems/ramfs-rootfs-initramfs.txt'.

  (mlet %store-monad ((init (gexp->script "init" exp
                                          #:modules modules
                                          #:guile guile)))
    (define builder
      #~(begin
          (use-modules (gnu build linux-initrd))
      (with-imported-modules '((guix cpio)
                               (guix build utils)
                               (guix build store-copy)
                               (gnu build linux-initrd))
        #~(begin
            (use-modules (gnu build linux-initrd))

          (mkdir #$output)
          (build-initrd (string-append #$output "/initrd")
                        #:guile #$guile
                        #:init #$init
                        ;; Copy everything INIT refers to into the initrd.
                        #:references-graphs '("closure")
                        #:gzip (string-append #$gzip "/bin/gzip"))))
            (mkdir #$output)
            (build-initrd (string-append #$output "/initrd")
                          #:guile #$guile
                          #:init #$init
                          ;; Copy everything INIT refers to into the initrd.
                          #:references-graphs '("closure")
                          #:gzip (string-append #$gzip "/bin/gzip")))))

   (gexp->derivation name builder
                     #:modules '((guix cpio)
                                 (guix build utils)
                                 (guix build store-copy)
                                 (gnu build linux-initrd))
                     #:references-graphs `(("closure" ,init)))))
    (gexp->derivation name builder
                      #:references-graphs `(("closure" ,init)))))

(define (flat-linux-module-directory linux modules)
  "Return a flat directory containing the Linux kernel modules listed in
MODULES and taken from LINUX."
  (define build-exp
    #~(begin
        (use-modules (ice-9 match) (ice-9 regex)
                     (srfi srfi-1)
                     (guix build utils)
                     (gnu build linux-modules))
    (with-imported-modules '((guix build utils)
                             (guix elf)
                             (gnu build linux-modules))
      #~(begin
          (use-modules (ice-9 match) (ice-9 regex)
                       (srfi srfi-1)
                       (guix build utils)
                       (gnu build linux-modules))

        (define (string->regexp str)
          ;; Return a regexp that matches STR exactly.
          (string-append "^" (regexp-quote str) "$"))
          (define (string->regexp str)
            ;; Return a regexp that matches STR exactly.
            (string-append "^" (regexp-quote str) "$"))

        (define module-dir
          (string-append #$linux "/lib/modules"))
          (define module-dir
            (string-append #$linux "/lib/modules"))

        (define (lookup module)
          (let ((name (ensure-dot-ko module)))
            (match (find-files module-dir (string->regexp name))
              ((file)
               file)
              (()
               (error "module not found" name module-dir))
              ((_ ...)
               (error "several modules by that name"
                      name module-dir)))))
          (define (lookup module)
            (let ((name (ensure-dot-ko module)))
              (match (find-files module-dir (string->regexp name))
                ((file)
                 file)
                (()
                 (error "module not found" name module-dir))
                ((_ ...)
                 (error "several modules by that name"
                        name module-dir)))))

        (define modules
          (let ((modules (map lookup '#$modules)))
            (append modules
                    (recursive-module-dependencies modules
                                                   #:lookup-module lookup))))
          (define modules
            (let ((modules (map lookup '#$modules)))
              (append modules
                      (recursive-module-dependencies modules
                                                     #:lookup-module lookup))))

        (mkdir #$output)
        (for-each (lambda (module)
                    (format #t "copying '~a'...~%" module)
                    (copy-file module
                               (string-append #$output "/"
                                              (basename module))))
                  (delete-duplicates modules))))
          (mkdir #$output)
          (for-each (lambda (module)
                      (format #t "copying '~a'...~%" module)
                      (copy-file module
                                 (string-append #$output "/"
                                                (basename module))))
                    (delete-duplicates modules)))))

  (gexp->derivation "linux-modules" build-exp
                    #:modules '((guix build utils)
                                (guix elf)
                                (gnu build linux-modules))))
  (gexp->derivation "linux-modules" build-exp))

(define* (base-initrd file-systems
                      #:key


@@ 227,38 223,38 @@ loaded at boot time in the order in which they appear."
  (mlet %store-monad ((kodir (flat-linux-module-directory linux
                                                          linux-modules)))
    (expression->initrd
     #~(begin
         (use-modules (gnu build linux-boot)
                      (guix build utils)
                      (guix build bournish)   ;add the 'bournish' meta-command
                      (srfi srfi-26)
     (with-imported-modules '((guix build bournish)
                              (guix build utils)
                              (guix build syscalls)
                              (gnu build linux-boot)
                              (gnu build linux-modules)
                              (gnu build file-systems)
                              (guix elf))
       #~(begin
           (use-modules (gnu build linux-boot)
                        (guix build utils)
                        (guix build bournish) ;add the 'bournish' meta-command
                        (srfi srfi-26)

                      ;; FIXME: The following modules are for
                      ;; LUKS-DEVICE-MAPPING.  We should instead propagate
                      ;; this info via gexps.
                      ((gnu build file-systems)
                       #:select (find-partition-by-luks-uuid))
                      (rnrs bytevectors))
                        ;; FIXME: The following modules are for
                        ;; LUKS-DEVICE-MAPPING.  We should instead propagate
                        ;; this info via gexps.
                        ((gnu build file-systems)
                         #:select (find-partition-by-luks-uuid))
                        (rnrs bytevectors))

         (with-output-to-port (%make-void-port "w")
           (lambda ()
             (set-path-environment-variable "PATH" '("bin" "sbin")
                                            '#$helper-packages)))
           (with-output-to-port (%make-void-port "w")
             (lambda ()
               (set-path-environment-variable "PATH" '("bin" "sbin")
                                              '#$helper-packages)))

         (boot-system #:mounts '#$(map file-system->spec file-systems)
                      #:pre-mount (lambda ()
                                    (and #$@device-mapping-commands))
                      #:linux-modules '#$linux-modules
                      #:linux-module-directory '#$kodir
                      #:qemu-guest-networking? #$qemu-networking?
                      #:volatile-root? '#$volatile-root?))
     #:name "base-initrd"
     #:modules '((guix build bournish)
                 (guix build utils)
                 (guix build syscalls)
                 (gnu build linux-boot)
                 (gnu build linux-modules)
                 (gnu build file-systems)
                 (guix elf)))))
           (boot-system #:mounts '#$(map file-system->spec file-systems)
                        #:pre-mount (lambda ()
                                      (and #$@device-mapping-commands))
                        #:linux-modules '#$linux-modules
                        #:linux-module-directory '#$kodir
                        #:qemu-guest-networking? #$qemu-networking?
                        #:volatile-root? '#$volatile-root?)))
     #:name "base-initrd")))

;;; linux-initrd.scm ends here

M gnu/system/locale.scm => gnu/system/locale.scm +4 -4
@@ 154,10 154,10 @@ data format changes between libc versions."
                                                                #:libc libc))
                                     libcs)))
       (gexp->derivation "locale-multiple-versions"
                         #~(begin
                             (use-modules (guix build union))
                             (union-build #$output (list #$@dirs)))
                         #:modules '((guix build union))
                         (with-imported-modules '((guix build union))
                           #~(begin
                               (use-modules (guix build union))
                               (union-build #$output (list #$@dirs))))
                         #:local-build? #t
                         #:substitutable? #f)))))


M gnu/system/shadow.scm => gnu/system/shadow.scm +36 -36
@@ 139,10 139,11 @@
    `(fontconfig (dir "/run/current-system/profile/share/fonts")))

  (define copy-guile-wm
    #~(begin
        (use-modules (guix build utils))
        (copy-file (car (find-files #$guile-wm "wm-init-sample.scm"))
                   #$output)))
    (with-imported-modules '((guix build utils))
      #~(begin
          (use-modules (guix build utils))
          (copy-file (car (find-files #$guile-wm "wm-init-sample.scm"))
                     #$output))))

  (let ((profile (plain-file "bash_profile" "\
# Honor per-interactive-shell startup file


@@ 176,27 177,26 @@ alias ll='ls -l'\n"))
        (zlogin    (plain-file "zlogin" "\
# Honor system-wide environment variables
source /etc/profile\n"))
        (guile-wm  (computed-file "guile-wm" copy-guile-wm
                                  #:modules '((guix build utils))))
        (guile-wm  (computed-file "guile-wm" copy-guile-wm))
        (xdefaults (plain-file "Xdefaults" "\
XTerm*utf8: always
XTerm*metaSendsEscape: true\n"))
        (fonts.conf (computed-file
                     "fonts.conf"
                     #~(begin
                         (use-modules (guix build utils)
                                      (sxml simple))

                         (define dir
                           (string-append #$output
                                          "/fontconfig"))

                         (mkdir-p dir)
                         (call-with-output-file (string-append dir
                                                             "/fonts.conf")
                           (lambda (port)
                             (sxml->xml '#$fonts.conf-content port))))
                     #:modules '((guix build utils))))
                     (with-imported-modules '((guix build utils))
                       #~(begin
                           (use-modules (guix build utils)
                                        (sxml simple))

                           (define dir
                             (string-append #$output
                                            "/fontconfig"))

                           (mkdir-p dir)
                           (call-with-output-file (string-append dir
                                                                 "/fonts.conf")
                             (lambda (port)
                               (sxml->xml '#$fonts.conf-content port)))))))
        (gdbinit   (plain-file "gdbinit" "\
# Tell GDB where to look for separate debugging files.
set debug-file-directory ~/.guix-profile/lib/debug\n")))


@@ 211,22 211,22 @@ set debug-file-directory ~/.guix-profile/lib/debug\n")))
(define (skeleton-directory skeletons)
  "Return a directory containing SKELETONS, a list of name/derivation tuples."
  (computed-file "skel"
                 #~(begin
                     (use-modules (ice-9 match)
                                  (guix build utils))

                     (mkdir #$output)
                     (chdir #$output)

                     ;; Note: copy the skeletons instead of symlinking
                     ;; them like 'file-union' does, because 'useradd'
                     ;; would just copy the symlinks as is.
                     (for-each (match-lambda
                                 ((target source)
                                  (copy-recursively source target)))
                               '#$skeletons)
                     #t)
                 #:modules '((guix build utils))))
                 (with-imported-modules '((guix build utils))
                   #~(begin
                       (use-modules (ice-9 match)
                                    (guix build utils))

                       (mkdir #$output)
                       (chdir #$output)

                       ;; Note: copy the skeletons instead of symlinking
                       ;; them like 'file-union' does, because 'useradd'
                       ;; would just copy the symlinks as is.
                       (for-each (match-lambda
                                   ((target source)
                                    (copy-recursively source target)))
                                 '#$skeletons)
                       #t))))

(define (assert-valid-users/groups users groups)
  "Raise an error if USERS refer to groups not listed in GROUPS."

M gnu/system/vm.scm => gnu/system/vm.scm +23 -23
@@ 155,34 155,34 @@ made available under the /xchg CIFS share."

    (define builder
      ;; Code that launches the VM that evaluates EXP.
      #~(begin
          (use-modules (guix build utils)
                       (gnu build vm))

          (let ((inputs  '#$(list qemu coreutils))
                (linux   (string-append #$linux "/bzImage"))
                (initrd  (string-append #$initrd "/initrd"))
                (loader  #$loader)
                (graphs  '#$(match references-graphs
                              (((graph-files . _) ...) graph-files)
                              (_ #f))))

            (set-path-environment-variable "PATH" '("bin") inputs)

            (load-in-linux-vm loader
                              #:output #$output
                              #:linux linux #:initrd initrd
                              #:memory-size #$memory-size
                              #:make-disk-image? #$make-disk-image?
                              #:disk-image-format #$disk-image-format
                              #:disk-image-size #$disk-image-size
                              #:references-graphs graphs))))
      (with-imported-modules modules
        #~(begin
            (use-modules (guix build utils)
                         (gnu build vm))

            (let ((inputs  '#$(list qemu coreutils))
                  (linux   (string-append #$linux "/bzImage"))
                  (initrd  (string-append #$initrd "/initrd"))
                  (loader  #$loader)
                  (graphs  '#$(match references-graphs
                                (((graph-files . _) ...) graph-files)
                                (_ #f))))

              (set-path-environment-variable "PATH" '("bin") inputs)

              (load-in-linux-vm loader
                                #:output #$output
                                #:linux linux #:initrd initrd
                                #:memory-size #$memory-size
                                #:make-disk-image? #$make-disk-image?
                                #:disk-image-format #$disk-image-format
                                #:disk-image-size #$disk-image-size
                                #:references-graphs graphs)))))

    (gexp->derivation name builder
                      ;; TODO: Require the "kvm" feature.
                      #:system system
                      #:env-vars env-vars
                      #:modules modules
                      #:guile-for-build guile-for-build
                      #:references-graphs references-graphs)))


M gnu/tests/base.scm => gnu/tests/base.scm +257 -257
@@ 70,125 70,125 @@
using COMMAND, a gexp that evaluates to a list of strings.  Compare some
properties of running system to what's declared in OS, an <operating-system>."
  (define test
    #~(begin
        (use-modules (gnu build marionette)
                     (srfi srfi-1)
                     (srfi srfi-26)
                     (srfi srfi-64)
                     (ice-9 match))

        (define marionette
          (make-marionette #$command))

        (mkdir #$output)
        (chdir #$output)

        (test-begin "basic")

        (test-assert "uname"
          (match (marionette-eval '(uname) marionette)
            (#("Linux" host-name version _ architecture)
             (and (string=? host-name
                            #$(operating-system-host-name os))
                  (string-prefix? #$(package-version
                                     (operating-system-kernel os))
                                  version)
                  (string-prefix? architecture %host-type)))))

        (test-assert "shell and user commands"
          ;; Is everything in $PATH?
          (zero? (marionette-eval '(system "
    (with-imported-modules '((gnu build marionette))
      #~(begin
          (use-modules (gnu build marionette)
                       (srfi srfi-1)
                       (srfi srfi-26)
                       (srfi srfi-64)
                       (ice-9 match))

          (define marionette
            (make-marionette #$command))

          (mkdir #$output)
          (chdir #$output)

          (test-begin "basic")

          (test-assert "uname"
            (match (marionette-eval '(uname) marionette)
              (#("Linux" host-name version _ architecture)
               (and (string=? host-name
                              #$(operating-system-host-name os))
                    (string-prefix? #$(package-version
                                       (operating-system-kernel os))
                                    version)
                    (string-prefix? architecture %host-type)))))

          (test-assert "shell and user commands"
            ;; Is everything in $PATH?
            (zero? (marionette-eval '(system "
. /etc/profile
set -e -x
guix --version
ls --version
grep --version
info --version")
                                  marionette)))

        (test-assert "accounts"
          (let ((users (marionette-eval '(begin
                                           (use-modules (ice-9 match))
                                           (let loop ((result '()))
                                             (match (getpw)
                                               (#f (reverse result))
                                               (x  (loop (cons x result))))))
                                        marionette)))
            (lset= string=?
                   (map passwd:name users)
                   (list
                    #$@(map user-account-name
                            (operating-system-user-accounts os))))))

        (test-assert "shepherd services"
          (let ((services (marionette-eval '(begin
                                              (use-modules (gnu services herd))
                                              (call-with-values current-services
                                                append))
                                           marionette)))
            (lset= eq?
                   (pk 'services services)
                   '(root #$@(operating-system-shepherd-service-names os)))))

        (test-equal "login on tty1"
          "root\n"
          (begin
            (marionette-control "sendkey ctrl-alt-f1" marionette)
            ;; Wait for the 'term-tty1' service to be running (using
            ;; 'start-service' is the simplest and most reliable way to do
            ;; that.)
                                    marionette)))

          (test-assert "accounts"
            (let ((users (marionette-eval '(begin
                                             (use-modules (ice-9 match))
                                             (let loop ((result '()))
                                               (match (getpw)
                                                 (#f (reverse result))
                                                 (x  (loop (cons x result))))))
                                          marionette)))
              (lset= string=?
                     (map passwd:name users)
                     (list
                      #$@(map user-account-name
                              (operating-system-user-accounts os))))))

          (test-assert "shepherd services"
            (let ((services (marionette-eval '(begin
                                                (use-modules (gnu services herd))
                                                (call-with-values current-services
                                                  append))
                                             marionette)))
              (lset= eq?
                     (pk 'services services)
                     '(root #$@(operating-system-shepherd-service-names os)))))

          (test-equal "login on tty1"
            "root\n"
            (begin
              (marionette-control "sendkey ctrl-alt-f1" marionette)
              ;; Wait for the 'term-tty1' service to be running (using
              ;; 'start-service' is the simplest and most reliable way to do
              ;; that.)
              (marionette-eval
               '(begin
                  (use-modules (gnu services herd))
                  (start-service 'term-tty1))
               marionette)

              ;; Now we can type.
              (marionette-type "root\n\nid -un > logged-in\n" marionette)

              ;; It can take a while before the shell commands are executed.
              (let loop ((i 0))
                (unless (or (file-exists? "/root/logged-in") (> i 15))
                  (sleep 1)
                  (loop (+ i 1))))
              (marionette-eval '(use-modules (rnrs io ports)) marionette)
              (marionette-eval '(call-with-input-file "/root/logged-in"
                                  get-string-all)
                               marionette)))

          (test-assert "host name resolution"
            (match (marionette-eval
                    '(begin
                       ;; Wait for nscd or our requests go through it.
                       (use-modules (gnu services herd))
                       (start-service 'nscd)

                       (list (getaddrinfo "localhost")
                             (getaddrinfo #$(operating-system-host-name os))))
                    marionette)
              ((((? vector?) ..1) ((? vector?) ..1))
               #t)
              (x
               (pk 'failure x #f))))

          (test-equal "host not found"
            #f
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (start-service 'term-tty1))
             marionette)

            ;; Now we can type.
            (marionette-type "root\n\nid -un > logged-in\n" marionette)

            ;; It can take a while before the shell commands are executed.
            (let loop ((i 0))
              (unless (or (file-exists? "/root/logged-in") (> i 15))
                (sleep 1)
                (loop (+ i 1))))
            (marionette-eval '(use-modules (rnrs io ports)) marionette)
            (marionette-eval '(call-with-input-file "/root/logged-in"
                                get-string-all)
                             marionette)))

        (test-assert "host name resolution"
          (match (marionette-eval
                  '(begin
                     ;; Wait for nscd or our requests go through it.
                     (use-modules (gnu services herd))
                     (start-service 'nscd)

                     (list (getaddrinfo "localhost")
                           (getaddrinfo #$(operating-system-host-name os))))
                  marionette)
            ((((? vector?) ..1) ((? vector?) ..1))
             #t)
            (x
             (pk 'failure x #f))))

        (test-equal "host not found"
          #f
          (marionette-eval
           '(false-if-exception (getaddrinfo "does-not-exist"))
           marionette))

        (test-assert "screendump"
          (begin
            (marionette-control (string-append "screendump " #$output
                                               "/tty1.ppm")
                                marionette)
            (file-exists? "tty1.ppm")))

        (test-end)
        (exit (= (test-runner-fail-count (test-runner-current)) 0))))

  (gexp->derivation name test
                    #:modules '((gnu build marionette))))
             '(false-if-exception (getaddrinfo "does-not-exist"))
             marionette))

          (test-assert "screendump"
            (begin
              (marionette-control (string-append "screendump " #$output
                                                 "/tty1.ppm")
                                  marionette)
              (file-exists? "tty1.ppm")))

          (test-end)
          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))

  (gexp->derivation name test))

(define %test-basic-os
  (system-test


@@ 243,67 243,67 @@ functionality tests.")
                       (command (system-qemu-image/shared-store-script
                                 os #:graphic? #f)))
    (define test
      #~(begin
          (use-modules (gnu build marionette)
                       (srfi srfi-64)
                       (ice-9 match))

          (define marionette
            (make-marionette (list #$command)))

          (define (wait-for-file file)
            ;; Wait until FILE exists in the guest; 'read' its content and
            ;; return it.
            (marionette-eval
             `(let loop ((i 10))
                (cond ((file-exists? ,file)
                       (call-with-input-file ,file read))
                      ((> i 0)
                       (sleep 1)
                       (loop (- i 1)))
                      (else
                       (error "file didn't show up" ,file))))
             marionette))

          (mkdir #$output)
          (chdir #$output)

          (test-begin "mcron")

          (test-eq "service running"
            'running!
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (start-service 'mcron)
                'running!)
             marionette))

          ;; Make sure root's mcron job runs, has its cwd set to "/root", and
          ;; runs with the right UID/GID.
          (test-equal "root's job"
            '(0 0)
            (wait-for-file "/root/witness"))

          ;; Likewise for Alice's job.  We cannot know what its GID is since
          ;; it's chosen by 'groupadd', but it's strictly positive.
          (test-assert "alice's job"
            (match (wait-for-file "/home/alice/witness")
              ((1000 gid)
               (>= gid 100))))

          ;; Last, the job that uses a command; allows us to test whether
          ;; $PATH is sane.  (Note that 'marionette-eval' stringifies objects
          ;; that don't have a read syntax, hence the string.)
          (test-equal "root's job with command"
            "#<eof>"
            (wait-for-file "/root/witness-touch"))

          (test-end)
          (exit (= (test-runner-fail-count (test-runner-current)) 0))))

    (gexp->derivation name test
                      #:modules '((gnu build marionette)))))
      (with-imported-modules '((gnu build marionette))
        #~(begin
            (use-modules (gnu build marionette)
                         (srfi srfi-64)
                         (ice-9 match))

            (define marionette
              (make-marionette (list #$command)))

            (define (wait-for-file file)
              ;; Wait until FILE exists in the guest; 'read' its content and
              ;; return it.
              (marionette-eval
               `(let loop ((i 10))
                  (cond ((file-exists? ,file)
                         (call-with-input-file ,file read))
                        ((> i 0)
                         (sleep 1)
                         (loop (- i 1)))
                        (else
                         (error "file didn't show up" ,file))))
               marionette))

            (mkdir #$output)
            (chdir #$output)

            (test-begin "mcron")

            (test-eq "service running"
              'running!
              (marionette-eval
               '(begin
                  (use-modules (gnu services herd))
                  (start-service 'mcron)
                  'running!)
               marionette))

            ;; Make sure root's mcron job runs, has its cwd set to "/root", and
            ;; runs with the right UID/GID.
            (test-equal "root's job"
              '(0 0)
              (wait-for-file "/root/witness"))

            ;; Likewise for Alice's job.  We cannot know what its GID is since
            ;; it's chosen by 'groupadd', but it's strictly positive.
            (test-assert "alice's job"
              (match (wait-for-file "/home/alice/witness")
                ((1000 gid)
                 (>= gid 100))))

            ;; Last, the job that uses a command; allows us to test whether
            ;; $PATH is sane.  (Note that 'marionette-eval' stringifies objects
            ;; that don't have a read syntax, hence the string.)
            (test-equal "root's job with command"
              "#<eof>"
              (wait-for-file "/root/witness-touch"))

            (test-end)
            (exit (= (test-runner-fail-count (test-runner-current)) 0)))))

    (gexp->derivation name test)))

(define %test-mcron
  (system-test


@@ 355,90 355,90 @@ functionality tests.")
                     ".local"))

    (define test
      #~(begin
          (use-modules (gnu build marionette)
                       (srfi srfi-1)
                       (srfi srfi-64)
                       (ice-9 match))

          (define marionette
            (make-marionette (list #$run)))

          (mkdir #$output)
          (chdir #$output)

          (test-begin "avahi")

          (test-assert "wait for services"
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))

                (start-service 'nscd)

                ;; XXX: Work around a race condition in nscd: nscd creates its
                ;; PID file before it is listening on its socket.
                (let ((sock (socket PF_UNIX SOCK_STREAM 0)))
                  (let try ()
                    (catch 'system-error
                      (lambda ()
                        (connect sock AF_UNIX "/var/run/nscd/socket")
                        (close-port sock)
                        (format #t "nscd is ready~%"))
                      (lambda args
                        (format #t "waiting for nscd...~%")
                        (usleep 500000)
                        (try)))))

                ;; Wait for the other useful things.
                (start-service 'avahi-daemon)
                (start-service 'networking)

                #t)
             marionette))

          (test-equal "avahi-resolve-host-name"
            0
            (marionette-eval
             '(system*
               "/run/current-system/profile/bin/avahi-resolve-host-name"
               "-v" #$mdns-host-name)
             marionette))

          (test-equal "avahi-browse"
            0
            (marionette-eval
             '(system* "avahi-browse" "-avt")
             marionette))

          (test-assert "getaddrinfo .local"
            ;; Wait for the 'avahi-daemon' service and perform a resolution.
            (match (marionette-eval
                    '(getaddrinfo #$mdns-host-name)
                    marionette)
              (((? vector? addrinfos) ..1)
               (pk 'getaddrinfo addrinfos)
               (and (any (lambda (ai)
                           (= AF_INET (addrinfo:fam ai)))
                         addrinfos)
                    (any (lambda (ai)
                           (= AF_INET6 (addrinfo:fam ai)))
                         addrinfos)))))

          (test-assert "gethostbyname .local"
            (match (pk 'gethostbyname
                       (marionette-eval '(gethostbyname #$mdns-host-name)
                                        marionette))
              ((? vector? result)
               (and (string=? (hostent:name result) #$mdns-host-name)
                    (= (hostent:addrtype result) AF_INET)))))


          (test-end)
          (exit (= (test-runner-fail-count (test-runner-current)) 0))))

    (gexp->derivation "nss-mdns" test
                      #:modules '((gnu build marionette)))))
      (with-imported-modules '((gnu build marionette))
        #~(begin
            (use-modules (gnu build marionette)
                         (srfi srfi-1)
                         (srfi srfi-64)
                         (ice-9 match))

            (define marionette
              (make-marionette (list #$run)))

            (mkdir #$output)
            (chdir #$output)

            (test-begin "avahi")

            (test-assert "wait for services"
              (marionette-eval
               '(begin
                  (use-modules (gnu services herd))

                  (start-service 'nscd)

                  ;; XXX: Work around a race condition in nscd: nscd creates its
                  ;; PID file before it is listening on its socket.
                  (let ((sock (socket PF_UNIX SOCK_STREAM 0)))
                    (let try ()
                      (catch 'system-error
                        (lambda ()
                          (connect sock AF_UNIX "/var/run/nscd/socket")
                          (close-port sock)
                          (format #t "nscd is ready~%"))
                        (lambda args
                          (format #t "waiting for nscd...~%")
                          (usleep 500000)
                          (try)))))

                  ;; Wait for the other useful things.
                  (start-service 'avahi-daemon)
                  (start-service 'networking)

                  #t)
               marionette))

            (test-equal "avahi-resolve-host-name"
              0
              (marionette-eval
               '(system*
                 "/run/current-system/profile/bin/avahi-resolve-host-name"
                 "-v" #$mdns-host-name)
               marionette))

            (test-equal "avahi-browse"
              0
              (marionette-eval
               '(system* "avahi-browse" "-avt")
               marionette))

            (test-assert "getaddrinfo .local"
              ;; Wait for the 'avahi-daemon' service and perform a resolution.
              (match (marionette-eval
                      '(getaddrinfo #$mdns-host-name)
                      marionette)
                (((? vector? addrinfos) ..1)
                 (pk 'getaddrinfo addrinfos)
                 (and (any (lambda (ai)
                             (= AF_INET (addrinfo:fam ai)))
                           addrinfos)
                      (any (lambda (ai)
                             (= AF_INET6 (addrinfo:fam ai)))
                           addrinfos)))))

            (test-assert "gethostbyname .local"
              (match (pk 'gethostbyname
                         (marionette-eval '(gethostbyname #$mdns-host-name)
                                          marionette))
                ((? vector? result)
                 (and (string=? (hostent:name result) #$mdns-host-name)
                      (= (hostent:addrtype result) AF_INET)))))


            (test-end)
            (exit (= (test-runner-fail-count (test-runner-current)) 0)))))

    (gexp->derivation "nss-mdns" test)))

(define %test-nss-mdns
  (system-test

M gnu/tests/install.scm => gnu/tests/install.scm +41 -41
@@ 119,43 119,45 @@ TARGET-SIZE bytes containing the installed system."
                                 os (list target))
                                #:disk-image-size (* 1500 MiB))))
    (define install
      #~(begin
          (use-modules (guix build utils)
                       (gnu build marionette))

          (set-path-environment-variable "PATH" '("bin")
                                         (list #$qemu-minimal))

          (system* "qemu-img" "create" "-f" "qcow2"
                   #$output #$(number->string target-size))

          (define marionette
            (make-marionette
             (cons (which #$(qemu-command system))
                   (cons* "-no-reboot" "-m" "800"
                          "-drive"
                          (string-append "file=" #$image
                                         ",if=virtio,readonly")
                          "-drive"
                          (string-append "file=" #$output ",if=virtio")
                          (if (file-exists? "/dev/kvm")
                              '("-enable-kvm")
                              '())))))

          (pk 'uname (marionette-eval '(uname) marionette))

          ;; Wait for tty1.
          (marionette-eval '(begin
                              (use-modules (gnu services herd))
                              (start 'term-tty1))
                           marionette)

          (marionette-eval '(call-with-output-file "/etc/litl-config.scm"
                              (lambda (port)
                                (write '#$%minimal-os-source port)))
                           marionette)

          (exit (marionette-eval '(zero? (system "
      (with-imported-modules '((guix build utils)
                               (gnu build marionette))
        #~(begin
            (use-modules (guix build utils)
                         (gnu build marionette))

            (set-path-environment-variable "PATH" '("bin")
                                           (list #$qemu-minimal))

            (system* "qemu-img" "create" "-f" "qcow2"
                     #$output #$(number->string target-size))

            (define marionette
              (make-marionette
               (cons (which #$(qemu-command system))
                     (cons* "-no-reboot" "-m" "800"
                            "-drive"
                            (string-append "file=" #$image
                                           ",if=virtio,readonly")
                            "-drive"
                            (string-append "file=" #$output ",if=virtio")
                            (if (file-exists? "/dev/kvm")
                                '("-enable-kvm")
                                '())))))

            (pk 'uname (marionette-eval '(uname) marionette))

            ;; Wait for tty1.
            (marionette-eval '(begin
                                (use-modules (gnu services herd))
                                (start 'term-tty1))
                             marionette)

            (marionette-eval '(call-with-output-file "/etc/litl-config.scm"
                                (lambda (port)
                                  (write '#$%minimal-os-source port)))
                             marionette)

            (exit (marionette-eval '(zero? (system "
. /etc/profile
set -e -x;
guix --version


@@ 178,11 180,9 @@ cp /etc/litl-config.scm /mnt/etc/config.scm
guix system init /mnt/etc/config.scm /mnt --no-substitutes
sync
reboot\n"))
                                 marionette))))
                                   marionette)))))

    (gexp->derivation "installation" install
                      #:modules '((guix build utils)
                                  (gnu build marionette)))))
    (gexp->derivation "installation" install)))


(define %test-installed-os