;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 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>
#:use-module (gnu packages disk)
#:use-module (gnu packages zile)
#:use-module (gnu packages linux)
- #: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")
(flags '(read-only))
(options "trans=virtio,cache=loose")
(check? #f))
-
- ;; The 9p documentation says that cache=loose is "intended for
- ;; exclusive, read-only mounts", without additional details. In
- ;; practice it seems to work well for these, and it's much faster than
- ;; the default cache=none, especially when copying and registering
- ;; store items.
(file-system
(mount-point "/xchg")
(device "xchg")
(type "9p")
(needed-for-boot? #t)
- (options "trans=virtio,cache=loose")
+ (options "trans=virtio")
(check? #f))
(file-system
(mount-point "/tmp")
(define* (expression->derivation-in-linux-vm name exp
#:key
- (system (%current-system))
+ (system (%current-system)) target
(linux linux-libre)
initrd
(qemu qemu-minimal)
(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 FILE-SYSTEMS, which, by default, includes a
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."
+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))
;; the initrd. See example at
;; <https://lists.gnu.org/archive/html/guix-devel/2017-10/msg00233.html>.
(program-file "linux-vm-loader"
- ;; When USER-BUILDER succeeds, reboot (indicating a
- ;; success), otherwise die, which causes a kernel panic
- ;; ("Attempted to kill init!").
- #~(if (zero? (system* #$user-builder))
- (reboot)
- (exit 1))))
+ ;; 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
(use-modules (guix build utils)
(gnu build vm))
- (let* ((inputs '#$(list qemu (canonical-package coreutils)))
+ (let* ((native-inputs
+ '#+(list qemu (canonical-package coreutils)))
(linux (string-append #$linux "/"
#$(system-linux-image-file-name)))
(initrd #$initrd)
(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") inputs)
+ (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?’ may not operate on
- ;; the right system/target values. Rewrite
+ ;; 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
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)."
(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 qemu parted e2fsprogs dosfstools xorriso)
+ '#$(append (list parted e2fsprogs dosfstools xorriso)
(map canonical-package
(list sed grep coreutils findutils gawk))))
inputs)))
(set-path-environment-variable "PATH" '("bin" "sbin") inputs)
- (make-iso9660-image #$(bootloader-package bootloader)
+ (make-iso9660-image #$xorriso
+ '#$grub-mkrescue-environment
+ #$(bootloader-package bootloader)
#$bootcfg-drv
#$os
"/xchg/guixsd.iso"
#: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>.
#: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")
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
(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 qemu parted e2fsprogs dosfstools)
+ '#$(append (list parted e2fsprogs dosfstools)
(map canonical-package
(list sed grep coreutils findutils gawk))))
;; 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
+ ;; FIXME: ‘target-arm?’ may be not operate on the right
;; system/target values. Rewrite using ‘let-system’ when
;; available.
- (if #$(target-arm32?)
+ (if #$(target-arm?)
'()
(list (partition
;; The standalone grub image is about 10MiB, but
;; when mounting. The actual FAT-ness is based
;; on file system size (16 in this case).
(file-system "vfat")
- (flags '(esp))))))))
+ (flags '(esp)))))))
+ (grub-efi #$(and (not (target-arm?)) grub-efi)))
(initialize-hard-disk "/dev/vda"
#:partitions partitions
- #:grub-efi #$grub-efi
+ #:grub-efi grub-efi
#:bootloader-package
#$(bootloader-package bootloader)
#:bootcfg #$bootcfg-drv
#: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 Guix System Docker image that has Guix
-installed inside of it. If you don't need Guix (e.g., your Docker
-image just contains a web server that is started by the Shepherd), then you
-should set REGISTER-CLOSURES? to #f."
+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"))))
- (mlet %store-monad ((os-drv (operating-system-derivation os #:container? #t))
- (name -> (string-append name ".tar.gz"))
- (graph -> "system-graph"))
+ (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-extensions (cons guile-json ;for (guix docker)
+ (with-extensions (cons guile-json-3 ;for (guix docker)
gcrypt-sqlite3&co) ;for (guix store database)
(with-imported-modules `(,@(source-module-closure
'((guix docker)
;; 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
(initialize (root-partition-initializer
#:closures '(#$graph)
#:register-closures? #$register-closures?
- #:system-directory #$os-drv
+ #:system-directory #$os
;; De-duplication would fail due to
;; cross-device link errors, so don't do it.
#:deduplicate? #f))
(call-with-input-file
(string-append "/xchg/" #$graph)
read-reference-graph)))
- #$os-drv
+ #$os
+ #:entry-point '(#$boot-program #$os)
#:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
#:creation-time (make-time time-utc 0 1)
- #:transformations `((,root-directory -> "")))
+ #:transformations `((,root-directory -> ""))))))))
- ;; Make sure the tarball is fully written before rebooting.
- (sync))))))
(expression->derivation-in-linux-vm
name build
#:make-disk-image? #f
#:single-file-output? #t
- #:references-graphs `((,graph ,os-drv)))))
+ #:references-graphs `((,graph ,os)))))
\f
;;;
(let ((device (file-system-device fs)))
(list (file-system-mount-point fs)
(file-system-type fs)
- (cond ((file-system-label? device)
- (file-system-label->string device))
- ((uuid? device)
- (uuid->string device))
- ((string? device)
- device)
- (else #f))
+ (file-system-device->string device)
(file-system-options fs))))
(if (eq? type 'iso9660)
'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))
(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.
;; Volume name of the root file system.
(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.
(initrd (lambda (file-systems . rest)
(apply (operating-system-initrd os)
file-systems
- #:volatile-root? #t
+ #:volatile-root? volatile?
rest)))
(bootloader (if (string=? "iso9660" file-system-type)
(bootloader grub-mkrescue-bootloader))
(operating-system-bootloader os)))
- ;; Force our own root file system.
+ ;; Force our own root file system. (We need a "/" file system
+ ;; to call 'root-uuid'.)
(file-systems (cons (file-system
(mount-point "/")
- (device root-uuid)
+ (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 root-uuid
+ #:file-system-uuid uuid
#:os os
- #:register-closures? #t
#:bootcfg-drv bootcfg
#:bootloader (bootloader-configuration-bootloader
(operating-system-bootloader os))
#:inputs `(("system" ,os)
- ("bootcfg" ,bootcfg)))
+ ("bootcfg" ,bootcfg))
+ #:grub-mkrescue-environment
+ '(("MKRESCUE_SED_MODE" . "mbr_hfs"))
+ #:substitutable? substitutable?)
(qemu-image #:name name
#:os os
#:bootcfg-drv bootcfg
#:disk-image-format "raw"
#:file-system-type file-system-type
#:file-system-label root-label
- #:file-system-uuid root-uuid
+ #:file-system-uuid uuid
#:copy-inputs? #t
- #:register-closures? #t
#:inputs `(("system" ,os)
- ("bootcfg" ,bootcfg))))))
+ ("bootcfg" ,bootcfg))
+ #:substitutable? substitutable?))))
(define* (system-qemu-image os
#:key
'())
"-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"
(($ <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