;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
;;; Copyright © 2016, 2017 Leo Famulari <leo@famulari.name>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
(define-module (gnu system vm)
#:use-module (guix config)
- #:use-module (guix docker)
#:use-module (guix store)
#:use-module (guix gexp)
#:use-module (guix derivations)
#:use-module (guix monads)
#:use-module (guix records)
#:use-module (guix modules)
- #:use-module (guix scripts pack)
#:use-module (guix utils)
- #:use-module (guix hash)
+ #:use-module (gcrypt hash)
#:use-module (guix base32)
+ #:use-module ((guix self) #:select (make-config.scm))
#:use-module ((gnu build vm)
#:select (qemu-command))
#:use-module (gnu packages cdrom)
#:use-module (gnu packages compression)
#:use-module (gnu packages guile)
- #:autoload (gnu packages gnupg) (libgcrypt)
+ #:autoload (gnu packages gnupg) (guile-gcrypt)
#:use-module (gnu packages gawk)
#:use-module (gnu packages bash)
#:use-module (gnu packages less)
#:use-module (gnu packages disk)
#:use-module (gnu packages zile)
#:use-module (gnu packages linux)
- #:use-module (gnu packages package-management)
- #:use-module ((gnu packages make-bootstrap)
- #:select (%guile-static-stripped))
#:use-module (gnu packages admin)
#:use-module (gnu bootloader)
#:use-module (gnu bootloader grub)
#:use-module (gnu system shadow)
#:use-module (gnu system pam)
+ #:use-module (gnu system linux-container)
#:use-module (gnu system linux-initrd)
#:use-module (gnu bootloader)
#:use-module (gnu system file-systems)
#:use-module (gnu system)
#:use-module (gnu services)
+ #:use-module (gnu services base)
#:use-module (gnu system uuid)
#:use-module (srfi srfi-1)
(define %linux-vm-file-systems
;; File systems mounted for 'derivation-in-linux-vm'. These are shared with
;; the host over 9p.
+ ;;
+ ;; The 9p documentation says that cache=loose is "intended for exclusive,
+ ;; read-only mounts", without additional details. It's much faster than the
+ ;; default cache=none, especially when copying and registering store items.
+ ;; Thus, use cache=loose, except for /xchg where we want to ensure
+ ;; consistency.
(list (file-system
(mount-point (%store-prefix))
(device "store")
(type "9p")
(needed-for-boot? #t)
- (options "trans=virtio")
+ (flags '(read-only))
+ (options "trans=virtio,cache=loose")
(check? #f))
(file-system
(mount-point "/xchg")
(device "tmp")
(type "9p")
(needed-for-boot? #t)
- (options "trans=virtio")
+ (options "trans=virtio,cache=loose")
(check? #f))))
+(define not-config?
+ ;; Select (guix …) and (gnu …) modules, except (guix config).
+ (match-lambda
+ (('guix 'config) #f)
+ (('guix rest ...) #t)
+ (('gnu rest ...) #t)
+ (rest #f)))
+
+(define gcrypt-sqlite3&co
+ ;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs.
+ (append-map (lambda (package)
+ (cons package
+ (match (package-transitive-propagated-inputs package)
+ (((labels packages) ...)
+ packages))))
+ (list guile-gcrypt guile-sqlite3)))
+
(define* (expression->derivation-in-linux-vm name exp
#:key
- (system (%current-system))
+ (system (%current-system)) target
(linux linux-libre)
initrd
(qemu qemu-minimal)
(env-vars '())
(guile-for-build
(%guile-for-build))
+ (file-systems
+ %linux-vm-file-systems)
(single-file-output? #f)
(make-disk-image? #f)
(references-graphs #f)
(memory-size 256)
(disk-image-format "qcow2")
- (disk-image-size 'guess))
+ (disk-image-size 'guess)
+
+ (substitutable? #t))
"Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a
derivation). The virtual machine runs with MEMORY-SIZE MiB of memory. In the
-virtual machine, EXP has access to all its inputs from the store; it should
-put its output file(s) in the '/xchg' directory.
+virtual machine, EXP has access to FILE-SYSTEMS, which, by default, includes a
+9p share of the store, the '/xchg' where EXP should put its output file(s),
+and a 9p share of /tmp.
If SINGLE-FILE-OUTPUT? is true, copy a single file from '/xchg' to OUTPUT.
Otherwise, copy the contents of /xchg to a new directory OUTPUT.
When REFERENCES-GRAPHS is true, it must be a list of file name/store path
pairs, as for `derivation'. The files containing the reference graphs are
-made available under the /xchg CIFS share."
- (mlet* %store-monad
- ((user-builder (gexp->file "builder-in-linux-vm" exp))
- (loader (gexp->file "linux-vm-loader"
- #~(primitive-load #$user-builder)))
- (coreutils -> (canonical-package coreutils))
- (initrd (if initrd ; use the default initrd?
- (return initrd)
- (base-initrd %linux-vm-file-systems
- #:on-error 'backtrace
- #:linux linux
- #:linux-modules %base-initrd-modules
- #:qemu-networking? #t))))
+made available under the /xchg CIFS share.
+
+SUBSTITUTABLE? determines whether the returned derivation should be marked as
+substitutable."
+ (define user-builder
+ (program-file "builder-in-linux-vm" exp))
+
+ (define loader
+ ;; Invoke USER-BUILDER instead using 'primitive-load'. The reason for
+ ;; this is to allow USER-BUILDER to dlopen stuff by using a full-featured
+ ;; Guile, which it couldn't do using the statically-linked guile used in
+ ;; the initrd. See example at
+ ;; <https://lists.gnu.org/archive/html/guix-devel/2017-10/msg00233.html>.
+ (program-file "linux-vm-loader"
+ ;; Communicate USER-BUILDER's exit status via /xchg so that
+ ;; the host can distinguish between success, failure, and
+ ;; kernel panic.
+ #~(let ((status (system* #$user-builder)))
+ (call-with-output-file "/xchg/.exit-status"
+ (lambda (port)
+ (write status port)))
+ (sync)
+ (reboot))))
+
+ (let ((initrd (or initrd
+ (base-initrd file-systems
+ #:on-error 'backtrace
+ #:linux linux
+ #:linux-modules %base-initrd-modules
+ #:qemu-networking? #t))))
(define builder
;; Code that launches the VM that evaluates EXP.
- (with-imported-modules (source-module-closure '((guix build utils)
- (gnu build vm)))
- #~(begin
- (use-modules (guix build utils)
- (gnu build vm))
-
- (let* ((inputs '#$(list qemu coreutils))
- (linux (string-append #$linux "/"
- #$(system-linux-image-file-name)))
- (initrd (string-append #$initrd "/initrd"))
- (loader #$loader)
- (graphs '#$(match references-graphs
- (((graph-files . _) ...) graph-files)
- (_ #f)))
- (size #$(if (eq? 'guess disk-image-size)
- #~(+ (* 70 (expt 2 20)) ;ESP
- (estimated-partition-size graphs))
- disk-image-size)))
-
- (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?
- #:single-file-output? #$single-file-output?
- ;; FIXME: ‘target-arm32?’ may not operate on
- ;; the right system/target values. Rewrite
- ;; using ‘let-system’ when available.
- #:target-arm32? #$(target-arm32?)
- #:disk-image-format #$disk-image-format
- #:disk-image-size size
- #:references-graphs graphs)))))
+ (with-extensions gcrypt-sqlite3&co
+ (with-imported-modules `(,@(source-module-closure
+ '((guix build utils)
+ (gnu build vm))
+ #:select? not-config?)
+
+ ;; For consumption by (gnu store database).
+ ((guix config) => ,(make-config.scm)))
+ #~(begin
+ (use-modules (guix build utils)
+ (gnu build vm))
+
+ (let* ((native-inputs
+ '#+(list qemu (canonical-package coreutils)))
+ (linux (string-append #$linux "/"
+ #$(system-linux-image-file-name)))
+ (initrd #$initrd)
+ (loader #$loader)
+ (graphs '#$(match references-graphs
+ (((graph-files . _) ...) graph-files)
+ (_ #f)))
+ (target #$(or (%current-target-system) (%current-system)))
+ (size #$(if (eq? 'guess disk-image-size)
+ #~(+ (* 70 (expt 2 20)) ;ESP
+ (estimated-partition-size graphs))
+ disk-image-size)))
+
+ (set-path-environment-variable "PATH" '("bin") native-inputs)
+
+ (load-in-linux-vm loader
+ #:output #$output
+ #:linux linux #:initrd initrd
+ #:qemu (qemu-command target)
+ #:memory-size #$memory-size
+ #:make-disk-image? #$make-disk-image?
+ #:single-file-output? #$single-file-output?
+ ;; FIXME: ‘target-arm32?’ and
+ ;; ‘target-aarch64?’ may not operate on the
+ ;; right system/target values. Rewrite
+ ;; using ‘let-system’ when available.
+ #:target-arm32? #$(target-arm32?)
+ #:target-aarch64? #$(target-aarch64?)
+ #:disk-image-format #$disk-image-format
+ #:disk-image-size size
+ #:references-graphs graphs))))))
(gexp->derivation name builder
;; TODO: Require the "kvm" feature.
#:system system
+ #:target target
#:env-vars env-vars
#:guile-for-build guile-for-build
- #:references-graphs references-graphs)))
+ #:references-graphs references-graphs
+ #:substitutable? substitutable?)))
+
+(define (has-guix-service-type? os)
+ "Return true if OS contains a service of the type GUIX-SERVICE-TYPE."
+ (not (not (find (lambda (service)
+ (eq? (service-kind service) guix-service-type))
+ (operating-system-services os)))))
(define* (iso9660-image #:key
(name "iso9660-image")
file-system-label
file-system-uuid
(system (%current-system))
+ (target (%current-target-system))
(qemu qemu-minimal)
- os-drv
+ os
bootcfg-drv
bootloader
- register-closures?
- (inputs '()))
+ (register-closures? (has-guix-service-type? os))
+ (inputs '())
+ (grub-mkrescue-environment '())
+ (substitutable? #t))
"Return a bootable, stand-alone iso9660 image.
INPUTS is a list of inputs (as for packages)."
+ (define schema
+ (and register-closures?
+ (local-file (search-path %load-path
+ "guix/store/schema.sql"))))
+
(expression->derivation-in-linux-vm
name
- (with-imported-modules (source-module-closure '((gnu build vm)
- (guix build utils)))
- #~(begin
- (use-modules (gnu build vm)
- (guix build utils))
-
- (let ((inputs
- '#$(append (list qemu parted e2fsprogs dosfstools xorriso)
- (map canonical-package
- (list sed grep coreutils findutils gawk))
- (if register-closures? (list guix) '())))
-
-
- (graphs '#$(match inputs
- (((names . _) ...)
- names)))
- ;; This variable is unused but allows us to add INPUTS-TO-COPY
- ;; as inputs.
- (to-register
- '#$(map (match-lambda
- ((name thing) thing)
- ((name thing output) `(,thing ,output)))
- inputs)))
-
- (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
- (make-iso9660-image #$(bootloader-package bootloader)
- #$bootcfg-drv
- #$os-drv
- "/xchg/guixsd.iso"
- #:register-closures? #$register-closures?
- #:closures graphs
- #:volume-id #$file-system-label
- #:volume-uuid #$(and=> file-system-uuid
- uuid-bytevector))
- (reboot))))
+ (with-extensions gcrypt-sqlite3&co
+ (with-imported-modules `(,@(source-module-closure '((gnu build vm)
+ (guix store database)
+ (guix build utils))
+ #:select? not-config?)
+ ((guix config) => ,(make-config.scm)))
+ #~(begin
+ (use-modules (gnu build vm)
+ (guix store database)
+ (guix build utils))
+
+ (sql-schema #$schema)
+
+ ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded.
+ (setenv "GUIX_LOCPATH"
+ #+(file-append glibc-utf8-locales "/lib/locale"))
+ (setlocale LC_ALL "en_US.utf8")
+
+ (let ((inputs
+ '#$(append (list parted e2fsprogs dosfstools xorriso)
+ (map canonical-package
+ (list sed grep coreutils findutils gawk))))
+
+
+ (graphs '#$(match inputs
+ (((names . _) ...)
+ names)))
+ ;; This variable is unused but allows us to add INPUTS-TO-COPY
+ ;; as inputs.
+ (to-register
+ '#$(map (match-lambda
+ ((name thing) thing)
+ ((name thing output) `(,thing ,output)))
+ inputs)))
+
+ (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
+ (make-iso9660-image #$xorriso
+ '#$grub-mkrescue-environment
+ #$(bootloader-package bootloader)
+ #$bootcfg-drv
+ #$os
+ "/xchg/guixsd.iso"
+ #:register-closures? #$register-closures?
+ #:closures graphs
+ #:volume-id #$file-system-label
+ #:volume-uuid #$(and=> file-system-uuid
+ uuid-bytevector))))))
#:system system
+ #:target target
+
+ ;; Keep a local file system for /tmp so that we can populate it directly as
+ ;; root and have files owned by root. See <https://bugs.gnu.org/31752>.
+ #:file-systems (remove (lambda (file-system)
+ (string=? (file-system-mount-point file-system)
+ "/tmp"))
+ %linux-vm-file-systems)
+
#:make-disk-image? #f
#:single-file-output? #t
- #:references-graphs inputs))
+ #:references-graphs inputs
+ #:substitutable? substitutable?
+
+ ;; Xorriso seems to be quite memory-hungry, so increase the VM's RAM size.
+ #:memory-size 512))
(define* (qemu-image #:key
(name "qemu-image")
(system (%current-system))
+ (target (%current-target-system))
(qemu qemu-minimal)
(disk-image-size 'guess)
(disk-image-format "qcow2")
(file-system-type "ext4")
file-system-label
file-system-uuid
- os-drv
+ os
bootcfg-drv
bootloader
- (register-closures? #t)
+ (register-closures? (has-guix-service-type? os))
(inputs '())
- copy-inputs?)
+ copy-inputs?
+ (substitutable? #t))
"Return a bootable, stand-alone QEMU image of type DISK-IMAGE-FORMAT (e.g.,
'qcow2' or 'raw'), with a root partition of type FILE-SYSTEM-TYPE.
Optionally, FILE-SYSTEM-LABEL can be specified as the volume name for the root
INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy
all of INPUTS into the image being built. When REGISTER-CLOSURES? is true,
register INPUTS in the store database of the image so that Guix can be used in
-the image."
+the image. By default, REGISTER-CLOSURES? is set to true only if a service of
+type GUIX-SERVICE-TYPE is present in the services definition of the operating
+system."
+ (define schema
+ (and register-closures?
+ (local-file (search-path %load-path
+ "guix/store/schema.sql"))))
+
(expression->derivation-in-linux-vm
name
- (with-imported-modules (source-module-closure '((gnu build bootloader)
- (gnu build vm)
- (guix build utils)))
- #~(begin
- (use-modules (gnu build bootloader)
- (gnu build vm)
- (guix build utils)
- (srfi srfi-26)
- (ice-9 binary-ports))
-
- (let ((inputs
- '#$(append (list qemu parted e2fsprogs dosfstools)
- (map canonical-package
- (list sed grep coreutils findutils gawk))
- (if register-closures? (list guix) '())))
-
- ;; This variable is unused but allows us to add INPUTS-TO-COPY
- ;; as inputs.
- (to-register
- '#$(map (match-lambda
- ((name thing) thing)
- ((name thing output) `(,thing ,output)))
- inputs)))
-
- (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
-
- (let* ((graphs '#$(match inputs
- (((names . _) ...)
- names)))
- (initialize (root-partition-initializer
- #:closures graphs
- #:copy-closures? #$copy-inputs?
- #:register-closures? #$register-closures?
- #:system-directory #$os-drv))
- (root-size #$(if (eq? 'guess disk-image-size)
- #~(max
- ;; Minimum 20 MiB root size
- (* 20 (expt 2 20))
- (estimated-partition-size
- (map (cut string-append "/xchg/" <>)
- graphs)))
- (- disk-image-size
- (* 50 (expt 2 20)))))
- (partitions
- (append
- (list (partition
- (size root-size)
- (label #$file-system-label)
- (uuid #$(and=> file-system-uuid
- uuid-bytevector))
- (file-system #$file-system-type)
- (flags '(boot))
- (initializer initialize)))
- ;; Append a small EFI System Partition for use with UEFI
- ;; bootloaders if we are not targeting ARM because UEFI
- ;; support in U-Boot is experimental.
- ;;
- ;; FIXME: ‘target-arm32?’ may be not operate on the right
- ;; system/target values. Rewrite using ‘let-system’ when
- ;; available.
- (if #$(target-arm32?)
- '()
- (list (partition
- ;; The standalone grub image is about 10MiB, but
- ;; leave some room for custom or multiple images.
- (size (* 40 (expt 2 20)))
- (label "GNU-ESP") ;cosmetic only
- ;; Use "vfat" here since this property is used
- ;; when mounting. The actual FAT-ness is based
- ;; on file system size (16 in this case).
- (file-system "vfat")
- (flags '(esp))))))))
- (initialize-hard-disk "/dev/vda"
- #:partitions partitions
- #:grub-efi #$grub-efi
- #:bootloader-package
- #$(bootloader-package bootloader)
- #:bootcfg #$bootcfg-drv
- #:bootcfg-location
- #$(bootloader-configuration-file bootloader)
- #:bootloader-installer
- #$(bootloader-installer bootloader))
- (reboot)))))
+ (with-extensions gcrypt-sqlite3&co
+ (with-imported-modules `(,@(source-module-closure '((gnu build vm)
+ (gnu build bootloader)
+ (guix store database)
+ (guix build utils))
+ #:select? not-config?)
+ ((guix config) => ,(make-config.scm)))
+ #~(begin
+ (use-modules (gnu build bootloader)
+ (gnu build vm)
+ (guix store database)
+ (guix build utils)
+ (srfi srfi-26)
+ (ice-9 binary-ports))
+
+ (sql-schema #$schema)
+
+ ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded.
+ (setenv "GUIX_LOCPATH"
+ #+(file-append glibc-utf8-locales "/lib/locale"))
+ (setlocale LC_ALL "en_US.utf8")
+
+ (let ((inputs
+ '#$(append (list parted e2fsprogs dosfstools)
+ (map canonical-package
+ (list sed grep coreutils findutils gawk))))
+
+ ;; This variable is unused but allows us to add INPUTS-TO-COPY
+ ;; as inputs.
+ (to-register
+ '#$(map (match-lambda
+ ((name thing) thing)
+ ((name thing output) `(,thing ,output)))
+ inputs)))
+
+ (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
+
+ (let* ((graphs '#$(match inputs
+ (((names . _) ...)
+ names)))
+ (initialize (root-partition-initializer
+ #:closures graphs
+ #:copy-closures? #$copy-inputs?
+ #:register-closures? #$register-closures?
+ #:system-directory #$os
+
+ ;; Disable deduplication to speed things up,
+ ;; and because it doesn't help much for a
+ ;; single system generation.
+ #:deduplicate? #f))
+ (root-size #$(if (eq? 'guess disk-image-size)
+ #~(max
+ ;; Minimum 20 MiB root size
+ (* 20 (expt 2 20))
+ (estimated-partition-size
+ (map (cut string-append "/xchg/" <>)
+ graphs)))
+ (- disk-image-size
+ (* 50 (expt 2 20)))))
+ (partitions
+ (append
+ (list (partition
+ (size root-size)
+ (label #$file-system-label)
+ (uuid #$(and=> file-system-uuid
+ uuid-bytevector))
+ (file-system #$file-system-type)
+ (flags '(boot))
+ (initializer initialize)))
+ ;; Append a small EFI System Partition for use with UEFI
+ ;; bootloaders if we are not targeting ARM because UEFI
+ ;; support in U-Boot is experimental.
+ ;;
+ ;; FIXME: ‘target-arm?’ may be not operate on the right
+ ;; system/target values. Rewrite using ‘let-system’ when
+ ;; available.
+ (if #$(target-arm?)
+ '()
+ (list (partition
+ ;; The standalone grub image is about 10MiB, but
+ ;; leave some room for custom or multiple images.
+ (size (* 40 (expt 2 20)))
+ (label "GNU-ESP") ;cosmetic only
+ ;; Use "vfat" here since this property is used
+ ;; when mounting. The actual FAT-ness is based
+ ;; on file system size (16 in this case).
+ (file-system "vfat")
+ (flags '(esp)))))))
+ (grub-efi #$(and (not (target-arm?)) grub-efi)))
+ (initialize-hard-disk "/dev/vda"
+ #:partitions partitions
+ #:grub-efi grub-efi
+ #:bootloader-package
+ #$(bootloader-package bootloader)
+ #:bootcfg #$bootcfg-drv
+ #:bootcfg-location
+ #$(bootloader-configuration-file bootloader)
+ #:bootloader-installer
+ #$(bootloader-installer bootloader)))))))
#:system system
+ #:target target
#:make-disk-image? #t
#:disk-image-size disk-image-size
#:disk-image-format disk-image-format
- #:references-graphs inputs))
+ #:references-graphs inputs
+ #:substitutable? substitutable?))
(define* (system-docker-image os
#:key
- (name "guixsd-docker-image")
- register-closures?)
+ (name "guix-docker-image")
+ (register-closures? (has-guix-service-type? os)))
"Build a docker image. OS is the desired <operating-system>. NAME is the
-base name to use for the output file. When REGISTER-CLOSURES? is not #f,
-register the closure of OS with Guix in the resulting Docker image. This only
-makes sense when you want to build a GuixSD Docker image that has Guix
-installed inside of it. If you don't need Guix (e.g., your GuixSD Docker
-image just contains a web server that is started by the Shepherd), then you
-should set REGISTER-CLOSURES? to #f."
- (define not-config?
- (match-lambda
- (('guix 'config) #f)
- (('guix rest ...) #t)
- (('gnu rest ...) #t)
- (rest #f)))
-
- (define config
- ;; (guix config) module for consumption by (guix gcrypt).
- (scheme-file "gcrypt-config.scm"
- #~(begin
- (define-module (guix config)
- #:export (%libgcrypt))
-
- ;; XXX: Work around <http://bugs.gnu.org/15602>.
- (eval-when (expand load eval)
- (define %libgcrypt
- #+(file-append libgcrypt "/lib/libgcrypt"))))))
- (mlet %store-monad ((os-drv (operating-system-derivation os #:container? #t))
- (name -> (string-append name ".tar.gz"))
- (graph -> "system-graph"))
+base name to use for the output file. When REGISTER-CLOSURES? is true,
+register the closure of OS with Guix in the resulting Docker image. By
+default, REGISTER-CLOSURES? is set to true only if a service of type
+GUIX-SERVICE-TYPE is present in the services definition of the operating
+system."
+ (define schema
+ (and register-closures?
+ (local-file (search-path %load-path
+ "guix/store/schema.sql"))))
+
+ (define boot-program
+ ;; Program that runs the boot script of OS, which in turn starts shepherd.
+ (program-file "boot-program"
+ #~(let ((system (cadr (command-line))))
+ (setenv "GUIX_NEW_SYSTEM" system)
+ (execl #$(file-append guile-2.2 "/bin/guile")
+ "guile" "--no-auto-compile"
+ (string-append system "/boot")))))
+
+
+ (let ((os (operating-system-with-gc-roots
+ (containerized-operating-system os '())
+ (list boot-program)))
+ (name (string-append name ".tar.gz"))
+ (graph "system-graph"))
(define build
- (with-imported-modules `(,@(source-module-closure '((guix docker)
- (guix build utils)
- (gnu build vm))
- #:select? not-config?)
- (guix build store-copy)
- ((guix config) => ,config))
- #~(begin
- ;; Guile-JSON is required by (guix docker).
- (add-to-load-path
- (string-append #+guile-json "/share/guile/site/"
- (effective-version)))
- (use-modules (guix docker)
- (guix build utils)
- (gnu build vm)
- (srfi srfi-19)
- (guix build store-copy))
-
- (let* ((inputs '#$(append (list tar)
- (if register-closures?
- (list guix)
- '())))
- ;; This initializer requires elevated privileges that are
- ;; not normally available in the build environment (e.g.,
- ;; it needs to create device nodes). In order to obtain
- ;; such privileges, we run it as root in a VM.
- (initialize (root-partition-initializer
- #:closures '(#$graph)
- #:register-closures? #$register-closures?
- #:system-directory #$os-drv
- ;; De-duplication would fail due to
- ;; cross-device link errors, so don't do it.
- #:deduplicate? #f))
- ;; Even as root in a VM, the initializer would fail due to
- ;; lack of privileges if we use a root-directory that is on
- ;; a file system that is shared with the host (e.g., /tmp).
- (root-directory "/guixsd-system-root"))
- (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
- (mkdir root-directory)
- (initialize root-directory)
- (build-docker-image
- (string-append "/xchg/" #$name) ;; The output file.
- (cons* root-directory
- (call-with-input-file (string-append "/xchg/" #$graph)
- read-reference-graph))
- #$os-drv
- #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
- #:creation-time (make-time time-utc 0 1)
- #:transformations `((,root-directory -> "")))))))
+ (with-extensions (cons guile-json-3 ;for (guix docker)
+ gcrypt-sqlite3&co) ;for (guix store database)
+ (with-imported-modules `(,@(source-module-closure
+ '((guix docker)
+ (guix store database)
+ (guix build utils)
+ (guix build store-copy)
+ (gnu build vm))
+ #:select? not-config?)
+ ((guix config) => ,(make-config.scm)))
+ #~(begin
+ (use-modules (guix docker)
+ (guix build utils)
+ (gnu build vm)
+ (srfi srfi-19)
+ (guix build store-copy)
+ (guix store database))
+
+ ;; Set the SQL schema location.
+ (sql-schema #$schema)
+
+ ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded.
+ (setenv "GUIX_LOCPATH"
+ #+(file-append glibc-utf8-locales "/lib/locale"))
+ (setlocale LC_ALL "en_US.utf8")
+
+ (let* (;; This initializer requires elevated privileges that are
+ ;; not normally available in the build environment (e.g.,
+ ;; it needs to create device nodes). In order to obtain
+ ;; such privileges, we run it as root in a VM.
+ (initialize (root-partition-initializer
+ #:closures '(#$graph)
+ #:register-closures? #$register-closures?
+ #:system-directory #$os
+ ;; De-duplication would fail due to
+ ;; cross-device link errors, so don't do it.
+ #:deduplicate? #f))
+ ;; Even as root in a VM, the initializer would fail due to
+ ;; lack of privileges if we use a root-directory that is on
+ ;; a file system that is shared with the host (e.g., /tmp).
+ (root-directory "/guixsd-system-root"))
+ (set-path-environment-variable "PATH" '("bin" "sbin") '(#+tar))
+ (mkdir root-directory)
+ (initialize root-directory)
+ (build-docker-image
+ (string-append "/xchg/" #$name) ;; The output file.
+ (cons* root-directory
+ (map store-info-item
+ (call-with-input-file
+ (string-append "/xchg/" #$graph)
+ read-reference-graph)))
+ #$os
+ #:entry-point '(#$boot-program #$os)
+ #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
+ #:creation-time (make-time time-utc 0 1)
+ #:transformations `((,root-directory -> ""))))))))
+
(expression->derivation-in-linux-vm
- name
- ;; The VM's initrd Guile doesn't support dlopen, but our "build" gexp
- ;; needs to be run by a Guile that can dlopen libgcrypt. The following
- ;; hack works around that problem by putting the "build" gexp into an
- ;; executable script (created by program-file) which, when executed, will
- ;; run using a Guile that supports dlopen. That way, the VM's initrd
- ;; Guile can just execute it via invoke, without using dlopen. See:
- ;; https://lists.gnu.org/archive/html/guix-devel/2017-10/msg00233.html
- (with-imported-modules `((guix build utils))
- #~(begin
- (use-modules (guix build utils))
- ;; If we use execl instead of invoke here, the VM will crash with a
- ;; kernel panic.
- (invoke #$(program-file "build-docker-image" build))))
+ name build
#:make-disk-image? #f
#:single-file-output? #t
- #:references-graphs `((,graph ,os-drv)))))
+ #:references-graphs `((,graph ,os)))))
\f
;;;
(define* (operating-system-uuid os #:optional (type 'dce))
"Compute UUID object with a deterministic \"UUID\" for OS, of the given
TYPE (one of 'iso9660 or 'dce). Return a UUID object."
+ ;; Note: For this to be deterministic, we must not hash things that contains
+ ;; (directly or indirectly) procedures, for example. That rules out
+ ;; anything that contains gexps, thunk or delayed record fields, etc.
+
+ (define service-name
+ (compose service-type-name service-kind))
+
+ (define (file-system-digest fs)
+ ;; Return a hashable digest that does not contain 'dependencies' since
+ ;; this field can contain procedures.
+ (let ((device (file-system-device fs)))
+ (list (file-system-mount-point fs)
+ (file-system-type fs)
+ (file-system-device->string device)
+ (file-system-options fs))))
+
(if (eq? type 'iso9660)
(let ((pad (compose (cut string-pad <> 2 #\0)
number->string))
- (h (hash (operating-system-services os) 3600)))
+ (h (hash (map service-name (operating-system-services os))
+ 3600)))
(bytevector->uuid
(string->iso9660-uuid
(string-append "1970-01-01-"
(pad (hash (operating-system-host-name os) 24)) "-"
(pad (quotient h 60)) "-"
(pad (modulo h 60)) "-"
- (pad (hash (operating-system-file-systems os) 100))))
+ (pad (hash (map file-system-digest
+ (operating-system-file-systems os))
+ 100))))
'iso9660))
(bytevector->uuid
(uint-list->bytevector
- (list (hash file-system-type
+ (list (hash (map file-system-digest
+ (operating-system-file-systems os))
(- (expt 2 32) 1))
(hash (operating-system-host-name os)
(- (expt 2 32) 1))
- (hash (operating-system-services os)
+ (hash (map service-name (operating-system-services os))
(- (expt 2 32) 1))
- (hash (operating-system-file-systems os)
+ (hash (map file-system-digest (operating-system-file-systems os))
(- (expt 2 32) 1)))
(endianness little)
4)
(name "disk-image")
(file-system-type "ext4")
(disk-image-size (* 900 (expt 2 20)))
- (volatile? #t))
+ (volatile? #t)
+ (substitutable? #t))
"Return the derivation of a disk image of DISK-IMAGE-SIZE bytes of the
system described by OS. Said image can be copied on a USB stick as is. When
VOLATILE? is true, the root file system is made volatile; this is useful
-to USB sticks meant to be read-only."
+to USB sticks meant to be read-only.
+
+SUBSTITUTABLE? determines whether the returned derivation should be marked as
+substitutable."
(define normalize-label
;; ISO labels are all-caps (case-insensitive), but since
;; 'find-partition-by-label' is case-sensitive, make it all-caps here.
(define root-label
;; Volume name of the root file system.
- (normalize-label "GuixSD_image"))
+ (normalize-label "Guix_image"))
- (define root-uuid
+ (define (root-uuid os)
;; UUID of the root file system, computed in a deterministic fashion.
;; This is what we use to locate the root file system so it has to be
;; different from the user's own file system UUIDs.
(string=? (file-system-mount-point fs) "/"))
(operating-system-file-systems os)))
- (let ((os (operating-system (inherit os)
- ;; Since this is meant to be used on real hardware, don't
- ;; install QEMU networking or anything like that. Assume USB
- ;; mass storage devices (usb-storage.ko) are available.
- (initrd (lambda (file-systems . rest)
- (apply (operating-system-initrd os)
- file-systems
- #:volatile-root? #t
- rest)))
-
- (bootloader (if (string=? "iso9660" file-system-type)
- (bootloader-configuration
- (inherit (operating-system-bootloader os))
- (bootloader grub-mkrescue-bootloader))
- (operating-system-bootloader os)))
-
- ;; Force our own root file system.
- (file-systems (cons (file-system
- (mount-point "/")
- (device root-uuid)
- (type file-system-type))
- file-systems-to-keep)))))
-
- (mlet* %store-monad ((os-drv (operating-system-derivation os))
- (bootcfg (operating-system-bootcfg os)))
- (if (string=? "iso9660" file-system-type)
- (iso9660-image #:name name
- #:file-system-label root-label
- #:file-system-uuid root-uuid
- #:os-drv os-drv
- #:register-closures? #t
- #:bootcfg-drv bootcfg
- #:bootloader (bootloader-configuration-bootloader
- (operating-system-bootloader os))
- #:inputs `(("system" ,os-drv)
- ("bootcfg" ,bootcfg)))
- (qemu-image #:name name
- #:os-drv os-drv
- #:bootcfg-drv bootcfg
- #:bootloader (bootloader-configuration-bootloader
- (operating-system-bootloader os))
- #:disk-image-size disk-image-size
- #:disk-image-format "raw"
- #:file-system-type file-system-type
- #:file-system-label root-label
- #:file-system-uuid root-uuid
- #:copy-inputs? #t
- #:register-closures? #t
- #:inputs `(("system" ,os-drv)
- ("bootcfg" ,bootcfg)))))))
+ (let* ((os (operating-system (inherit os)
+ ;; Since this is meant to be used on real hardware, don't
+ ;; install QEMU networking or anything like that. Assume USB
+ ;; mass storage devices (usb-storage.ko) are available.
+ (initrd (lambda (file-systems . rest)
+ (apply (operating-system-initrd os)
+ file-systems
+ #:volatile-root? volatile?
+ rest)))
+
+ (bootloader (if (string=? "iso9660" file-system-type)
+ (bootloader-configuration
+ (inherit (operating-system-bootloader os))
+ (bootloader grub-mkrescue-bootloader))
+ (operating-system-bootloader os)))
+
+ ;; Force our own root file system. (We need a "/" file system
+ ;; to call 'root-uuid'.)
+ (file-systems (cons (file-system
+ (mount-point "/")
+ (device "/dev/placeholder")
+ (type file-system-type))
+ file-systems-to-keep))))
+ (uuid (root-uuid os))
+ (os (operating-system
+ (inherit os)
+ (file-systems (cons (file-system
+ (mount-point "/")
+ (device uuid)
+ (type file-system-type))
+ file-systems-to-keep))))
+ (bootcfg (operating-system-bootcfg os)))
+ (if (string=? "iso9660" file-system-type)
+ (iso9660-image #:name name
+ #:file-system-label root-label
+ #:file-system-uuid uuid
+ #:os os
+ #:bootcfg-drv bootcfg
+ #:bootloader (bootloader-configuration-bootloader
+ (operating-system-bootloader os))
+ #:inputs `(("system" ,os)
+ ("bootcfg" ,bootcfg))
+ #:grub-mkrescue-environment
+ '(("MKRESCUE_SED_MODE" . "mbr_hfs"))
+ #:substitutable? substitutable?)
+ (qemu-image #:name name
+ #:os os
+ #:bootcfg-drv bootcfg
+ #:bootloader (bootloader-configuration-bootloader
+ (operating-system-bootloader os))
+ #:disk-image-size disk-image-size
+ #:disk-image-format "raw"
+ #:file-system-type file-system-type
+ #:file-system-label root-label
+ #:file-system-uuid uuid
+ #:copy-inputs? #t
+ #:inputs `(("system" ,os)
+ ("bootcfg" ,bootcfg))
+ #:substitutable? substitutable?))))
(define* (system-qemu-image os
#:key
'dce)))
- (let ((os (operating-system (inherit os)
- ;; Assume we have an initrd with the whole QEMU shebang.
-
- ;; Force our own root file system. Refer to it by UUID so that
- ;; it works regardless of how the image is used ("qemu -hda",
- ;; Xen, etc.).
- (file-systems (cons (file-system
- (mount-point "/")
- (device root-uuid)
- (type file-system-type))
- file-systems-to-keep)))))
- (mlet* %store-monad
- ((os-drv (operating-system-derivation os))
- (bootcfg (operating-system-bootcfg os)))
- (qemu-image #:os-drv os-drv
- #:bootcfg-drv bootcfg
- #:bootloader (bootloader-configuration-bootloader
- (operating-system-bootloader os))
- #:disk-image-size disk-image-size
- #:file-system-type file-system-type
- #:file-system-uuid root-uuid
- #:inputs `(("system" ,os-drv)
- ("bootcfg" ,bootcfg))
- #:copy-inputs? #t))))
+ (let* ((os (operating-system (inherit os)
+ ;; Assume we have an initrd with the whole QEMU shebang.
+
+ ;; Force our own root file system. Refer to it by UUID so that
+ ;; it works regardless of how the image is used ("qemu -hda",
+ ;; Xen, etc.).
+ (file-systems (cons (file-system
+ (mount-point "/")
+ (device root-uuid)
+ (type file-system-type))
+ file-systems-to-keep))))
+ (bootcfg (operating-system-bootcfg os)))
+ (qemu-image #:os os
+ #:bootcfg-drv bootcfg
+ #:bootloader (bootloader-configuration-bootloader
+ (operating-system-bootloader os))
+ #:disk-image-size disk-image-size
+ #:file-system-type file-system-type
+ #:file-system-uuid root-uuid
+ #:inputs `(("system" ,os)
+ ("bootcfg" ,bootcfg))
+ #:copy-inputs? #t)))
\f
;;;
;; force the traditional i386/BIOS method.
;; See <https://bugs.gnu.org/28768>.
(bootloader (bootloader-configuration
+ (inherit (operating-system-bootloader os))
(bootloader grub-bootloader)
(target "/dev/vda")))
;; Use a fixed UUID to improve determinism.
(operating-system-uuid os 'dce))
- (mlet* %store-monad ((os-drv (operating-system-derivation os))
- (bootcfg (operating-system-bootcfg os)))
- ;; XXX: When FULL-BOOT? is true, we end up creating an image that contains
- ;; BOOTCFG and all its dependencies, including the output of OS-DRV.
- ;; This is more than needed (we only need the kernel, initrd, GRUB for its
- ;; font, and the background image), but it's hard to filter that.
- (qemu-image #:os-drv os-drv
- #:bootcfg-drv bootcfg
- #:bootloader (bootloader-configuration-bootloader
- (operating-system-bootloader os))
- #:disk-image-size disk-image-size
- #:file-system-uuid root-uuid
- #:inputs (if full-boot?
- `(("bootcfg" ,bootcfg))
- '())
-
- ;; XXX: Passing #t here is too slow, so let it off by default.
- #:register-closures? #f
- #:copy-inputs? full-boot?)))
+ (define bootcfg
+ (operating-system-bootcfg os))
+
+ ;; XXX: When FULL-BOOT? is true, we end up creating an image that contains
+ ;; BOOTCFG and all its dependencies, including the output of OS.
+ ;; This is more than needed (we only need the kernel, initrd, GRUB for its
+ ;; font, and the background image), but it's hard to filter that.
+ (qemu-image #:os os
+ #:bootcfg-drv bootcfg
+ #:bootloader (bootloader-configuration-bootloader
+ (operating-system-bootloader os))
+ #:disk-image-size disk-image-size
+ #:file-system-uuid root-uuid
+ #:inputs (if full-boot?
+ `(("bootcfg" ,bootcfg))
+ '())
+
+ ;; XXX: Passing #t here is too slow, so let it off by default.
+ #:register-closures? #f
+ #:copy-inputs? full-boot?))
(define* (common-qemu-options image shared-fs)
"Return the a string-value gexp with the common QEMU options to boot IMAGE,
'())
"-no-reboot"
- "-net nic,model=virtio"
+ "-nic" "user,model=virtio-net-pci"
"-object" "rng-random,filename=/dev/urandom,id=guixsd-vm-rng"
"-device" "virtio-rng-pci,rng=guixsd-vm-rng"
DISK-IMAGE-SIZE parameter specifies the size in bytes of the root disk image;
it is mostly useful when FULL-BOOT? is true."
(mlet* %store-monad ((os -> (virtualized-operating-system os mappings full-boot?))
- (os-drv (operating-system-derivation os))
(image (system-qemu-image/shared-store
os
#:full-boot? full-boot?
#:disk-image-size disk-image-size)))
(define kernel-arguments
#~(list #$@(if graphic? #~() #~("console=ttyS0"))
- #+@(operating-system-kernel-arguments os os-drv "/dev/vda1")))
+ #+@(operating-system-kernel-arguments os "/dev/vda1")))
(define qemu-exec
#~(list (string-append #$qemu "/bin/" #$(qemu-command (%current-system)))
#$@(if full-boot?
#~()
#~("-kernel" #$(operating-system-kernel-file os)
- "-initrd" #$(file-append os-drv "/initrd")
+ "-initrd" #$(file-append os "/initrd")
(format #f "-append ~s"
(string-join #$kernel-arguments " "))))
#$@(common-qemu-options image
(($ <virtual-machine> os qemu graphic? memory-size disk-image-size
forwardings)
(let ((options
- `("-net" ,(string-append
- "user,"
+ `("-nic" ,(string-append
+ "user,model=virtio-net-pci,"
(port-forwardings->qemu-options forwardings)))))
(system-qemu-image/shared-store-script os
#:qemu qemu
HCoop / jackhill / guix / guix.git / blobdiff