aboutsummaryrefslogtreecommitdiff
path: root/gnu/system
diff options
context:
space:
mode:
authorMarius Bakke <mbakke@fastmail.com>2018-06-18 15:29:38 +0200
committerMarius Bakke <mbakke@fastmail.com>2018-06-18 15:29:38 +0200
commit6969c4de445a390eaa05de22bc5a537a76a76169 (patch)
tree9df3bdde497fdce705ae4eb66972f93a9ae111d9 /gnu/system
parent73d18915b597f2a386d6ae42930b49a13c8813b0 (diff)
parent32eb44240db23b2320a68a3ab17370531945587f (diff)
downloadguix-6969c4de445a390eaa05de22bc5a537a76a76169.tar
guix-6969c4de445a390eaa05de22bc5a537a76a76169.tar.gz
Merge branch 'master' into staging
Diffstat (limited to 'gnu/system')
-rw-r--r--gnu/system/file-systems.scm11
-rw-r--r--gnu/system/install.scm16
-rw-r--r--gnu/system/mapped-devices.scm16
-rw-r--r--gnu/system/vm.scm436
4 files changed, 272 insertions, 207 deletions
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index 2b5948256a..393dd0df70 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -194,10 +194,15 @@
;; differs from user to user.
(define (%store-prefix)
"Return the store prefix."
- (cond ((resolve-module '(guix store) #:ensure #f)
+ ;; Note: If we have (guix store database) in the search path and we do *not*
+ ;; have (guix store) proper, 'resolve-module' returns an empty (guix store)
+ ;; with one sub-module.
+ (cond ((and=> (resolve-module '(guix store) #:ensure #f)
+ (lambda (store)
+ (module-variable store '%store-prefix)))
=>
- (lambda (store)
- ((module-ref store '%store-prefix))))
+ (lambda (variable)
+ ((variable-ref variable))))
((getenv "NIX_STORE")
=> identity)
(else
diff --git a/gnu/system/install.scm b/gnu/system/install.scm
index 35f4ba9c24..6a3ae1947b 100644
--- a/gnu/system/install.scm
+++ b/gnu/system/install.scm
@@ -54,7 +54,8 @@
novena-installation-os
pine64-plus-installation-os
rk3399-puma-installation-os
- wandboard-installation-os))
+ wandboard-installation-os
+ os-with-u-boot))
;;; Commentary:
;;;
@@ -386,6 +387,19 @@ You have been warned. Thanks for being so brave.\x1b[0m
nvi ;:wq!
%base-packages))))
+(define* (os-with-u-boot os board #:key (bootloader-target "/dev/mmcblk0")
+ (triplet "arm-linux-gnueabihf"))
+ "Given OS, amend it with the u-boot bootloader for BOARD,
+installed to BOOTLOADER-TARGET (a drive), compiled for TRIPLET.
+
+If you want a serial console, make sure to specify one in your
+operating-system's kernel-arguments (\"console=ttyS0\" or similar)."
+ (operating-system (inherit os)
+ (bootloader (bootloader-configuration
+ (bootloader (bootloader (inherit u-boot-bootloader)
+ (package (make-u-boot-package board triplet))))
+ (target bootloader-target)))))
+
(define* (embedded-installation-os bootloader bootloader-target tty
#:key (extra-modules '()))
"Return an installation os for embedded systems.
diff --git a/gnu/system/mapped-devices.scm b/gnu/system/mapped-devices.scm
index a2cca0a93b..c452bdd894 100644
--- a/gnu/system/mapped-devices.scm
+++ b/gnu/system/mapped-devices.scm
@@ -32,7 +32,8 @@
#:use-module (gnu system uuid)
#:autoload (gnu build file-systems) (find-partition-by-luks-uuid)
#:autoload (gnu build linux-modules)
- (device-module-aliases matching-modules known-module-aliases)
+ (device-module-aliases matching-modules known-module-aliases
+ normalize-module-name)
#:autoload (gnu packages cryptsetup) (cryptsetup-static)
#:autoload (gnu packages linux) (mdadm-static)
#:use-module (srfi srfi-1)
@@ -127,10 +128,15 @@ DEVICE must be a \"/dev\" file name."
(const #f)))
(when aliases
- (let ((modules (delete-duplicates
- (append-map (cut matching-modules <> aliases)
- (device-module-aliases device)))))
- (unless (every (cute member <> linux-modules) modules)
+ (let ((modules (delete-duplicates
+ (append-map (cut matching-modules <> aliases)
+ (device-module-aliases device))))
+
+ ;; Module names (not file names) are supposed to use underscores
+ ;; instead of hyphens. MODULES is a list of module names, whereas
+ ;; LINUX-MODULES is file names without '.ko', so normalize them.
+ (provided (map normalize-module-name linux-modules)))
+ (unless (every (cut member <> provided) modules)
(raise (condition
(&message
(message (format #f (G_ "you may need these modules \
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 544c0e294d..b505b0cf6b 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -34,6 +34,7 @@
#:use-module (guix utils)
#:use-module (guix hash)
#:use-module (guix base32)
+ #:use-module ((guix self) #:select (make-config.scm))
#:use-module ((gnu build vm)
#:select (qemu-command))
@@ -50,7 +51,6 @@
#: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)
@@ -116,6 +116,19 @@
(options "trans=virtio")
(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 guile-sqlite3&co
+ ;; Guile-SQLite3 and its propagated inputs.
+ (cons guile-sqlite3
+ (package-transitive-propagated-inputs guile-sqlite3)))
+
(define* (expression->derivation-in-linux-vm name exp
#:key
(system (%current-system))
@@ -151,12 +164,28 @@ based on the size of the closure of REFERENCES-GRAPHS.
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."
+ (define config
+ ;; (guix config) module for consumption by (guix gcrypt).
+ (make-config.scm #:libgcrypt libgcrypt))
+
+ (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"
+ ;; When USER-BUILDER succeeds, reboot (indicating a
+ ;; success), otherwise die, which causes a kernel panic
+ ;; ("Attempted to kill init!").
+ #~(when (zero? (system* #$user-builder))
+ (reboot))))
+
(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?
+ ((initrd (if initrd ; use the default initrd?
(return initrd)
(base-initrd file-systems
#:on-error 'backtrace
@@ -166,40 +195,44 @@ made available under the /xchg CIFS share."
(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 guile-sqlite3&co
+ (with-imported-modules `(,@(source-module-closure
+ '((guix build utils)
+ (gnu build vm))
+ #:select? not-config?)
+ ((guix config) => ,config))
+ #~(begin
+ (use-modules (guix build utils)
+ (gnu build vm))
+
+ (let* ((inputs '#$(list qemu (canonical-package 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))))))
(gexp->derivation name builder
;; TODO: Require the "kvm" feature.
@@ -222,43 +255,56 @@ made available under the /xchg CIFS share."
"Return a bootable, stand-alone iso9660 image.
INPUTS is a list of inputs (as for packages)."
+ (define config
+ (make-config.scm #:libgcrypt libgcrypt))
+
+ (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 guile-sqlite3&co
+ (with-imported-modules `(,@(source-module-closure '((gnu build vm)
+ (guix store database)
+ (guix build utils))
+ #:select? not-config?)
+ ((guix config) => ,config))
+ #~(begin
+ (use-modules (gnu build vm)
+ (guix store database)
+ (guix build utils))
+
+ (sql-schema #$schema)
+
+ (let ((inputs
+ '#$(append (list qemu 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 #$(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))))))
#:system system
;; Keep a local file system for /tmp so that we can populate it directly as
@@ -301,91 +347,104 @@ 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."
+ (define config
+ (make-config.scm #:libgcrypt libgcrypt))
+
+ (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 guile-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) => ,config))
+ #~(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)
+
+ (let ((inputs
+ '#$(append (list qemu 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-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)))))))
#:system system
#:make-disk-image? #t
#:disk-image-size disk-image-size
@@ -403,49 +462,41 @@ 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))
+ (make-config.scm #:libgcrypt libgcrypt))
- ;; XXX: Work around <http://bugs.gnu.org/15602>.
- (eval-when (expand load eval)
- (define %libgcrypt
- #+(file-append libgcrypt "/lib/libgcrypt"))))))
+ (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 build
- (with-extensions (list guile-json) ;for (guix docker)
+ (with-extensions (cons guile-json ;for (guix docker)
+ guile-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 build store-copy)
((guix config) => ,config))
#~(begin
(use-modules (guix docker)
(guix build utils)
(gnu build vm)
(srfi srfi-19)
- (guix build store-copy))
+ (guix build store-copy)
+ (guix store database))
- (let* ((inputs '#$(append (list tar)
- (if register-closures?
- (list guix)
- '())))
- ;; This initializer requires elevated privileges that are
+ ;; Set the SQL schema location.
+ (sql-schema #$schema)
+
+ (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.
@@ -460,33 +511,22 @@ should set REGISTER-CLOSURES? to #f."
;; 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)
+ (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
- (call-with-input-file (string-append "/xchg/" #$graph)
- read-reference-graph))
+ (map store-info-item
+ (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 -> ""))))))))
(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)))))