diff options
Diffstat (limited to 'gnu/system')
| -rw-r--r-- | gnu/system/examples/bare-bones.tmpl | 3 | ||||
| -rw-r--r-- | gnu/system/examples/beaglebone-black.tmpl | 3 | ||||
| -rw-r--r-- | gnu/system/examples/lightweight-desktop.tmpl | 4 | ||||
| -rw-r--r-- | gnu/system/examples/vm-image.tmpl | 3 | ||||
| -rw-r--r-- | gnu/system/file-systems.scm | 111 | ||||
| -rw-r--r-- | gnu/system/install.scm | 36 | ||||
| -rw-r--r-- | gnu/system/linux-initrd.scm | 2 | ||||
| -rw-r--r-- | gnu/system/shadow.scm | 3 | ||||
| -rw-r--r-- | gnu/system/uuid.scm | 11 | ||||
| -rw-r--r-- | gnu/system/vm.scm | 125 |
10 files changed, 212 insertions, 89 deletions
diff --git a/gnu/system/examples/bare-bones.tmpl b/gnu/system/examples/bare-bones.tmpl index 7e0c8fbee0..cb6d2623db 100644 --- a/gnu/system/examples/bare-bones.tmpl +++ b/gnu/system/examples/bare-bones.tmpl @@ -16,8 +16,7 @@ (bootloader grub-bootloader) (target "/dev/sdX"))) (file-systems (cons (file-system - (device "my-root") - (title 'label) + (device (file-system-label "my-root")) (mount-point "/") (type "ext4")) %base-file-systems)) diff --git a/gnu/system/examples/beaglebone-black.tmpl b/gnu/system/examples/beaglebone-black.tmpl index 97201330c7..d1130c76b6 100644 --- a/gnu/system/examples/beaglebone-black.tmpl +++ b/gnu/system/examples/beaglebone-black.tmpl @@ -20,8 +20,7 @@ (initrd-modules (cons "omap_hsmmc" %base-initrd-modules)) (file-systems (cons (file-system - (device "my-root") - (title 'label) + (device (file-system-label "my-root")) (mount-point "/") (type "ext4")) %base-file-systems)) diff --git a/gnu/system/examples/lightweight-desktop.tmpl b/gnu/system/examples/lightweight-desktop.tmpl index 65a8ee1809..360ee62ffe 100644 --- a/gnu/system/examples/lightweight-desktop.tmpl +++ b/gnu/system/examples/lightweight-desktop.tmpl @@ -20,13 +20,11 @@ ;; Assume the target root file system is labelled "my-root", ;; and the EFI System Partition has UUID 1234-ABCD. (file-systems (cons* (file-system - (device "my-root") - (title 'label) + (device (file-system-label "my-root")) (mount-point "/") (type "ext4")) (file-system (device (uuid "1234-ABCD" 'fat)) - (title 'uuid) (mount-point "/boot/efi") (type "vfat")) %base-file-systems)) diff --git a/gnu/system/examples/vm-image.tmpl b/gnu/system/examples/vm-image.tmpl index ce3653c8b4..36e272722d 100644 --- a/gnu/system/examples/vm-image.tmpl +++ b/gnu/system/examples/vm-image.tmpl @@ -31,8 +31,7 @@ partprobe, and then 2) resizing the filesystem with resize2fs.\n")) (target "/dev/sda") (terminal-outputs '(console)))) (file-systems (cons (file-system - (device "my-root") - (title 'label) + (device (file-system-label "my-root")) (mount-point "/") (type "ext4")) %base-file-systems)) diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index d2acd705de..2b5948256a 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -20,16 +20,17 @@ #:use-module (ice-9 match) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) #:use-module (guix records) #:use-module (gnu system uuid) #:re-export (uuid ;backward compatibility string->uuid uuid->string) - #:export (<file-system> - file-system + #:export (file-system file-system? file-system-device - file-system-title + file-system-title ;deprecated file-system-mount-point file-system-type file-system-needed-for-boot? @@ -43,6 +44,10 @@ file-system-type-predicate + file-system-label + file-system-label? + file-system-label->string + file-system->spec spec->file-system specification->file-system-mapping @@ -83,12 +88,10 @@ ;;; Code: ;; File system declaration. -(define-record-type* <file-system> file-system +(define-record-type* <file-system> %file-system make-file-system file-system? - (device file-system-device) ; string - (title file-system-title ; 'device | 'label | 'uuid - (default 'device)) + (device file-system-device) ; string | <uuid> | <file-system-label> (mount-point file-system-mount-point) ; string (type file-system-type) ; string (flags file-system-flags ; list of symbols @@ -109,6 +112,83 @@ (default (current-source-location)) (innate))) +;; A file system label for use in the 'device' field. +(define-record-type <file-system-label> + (file-system-label label) + file-system-label? + (label file-system-label->string)) + +(set-record-type-printer! <file-system-label> + (lambda (obj port) + (format port "#<file-system-label ~s>" + (file-system-label->string obj)))) + +(define-syntax report-deprecation + (lambda (s) + "Report the use of the now-deprecated 'title' field." + (syntax-case s () + ((_ field) + (let* ((source (syntax-source #'field)) + (file (and source (assq-ref source 'filename))) + (line (and source + (and=> (assq-ref source 'line) 1+))) + (column (and source (assq-ref source 'column)))) + (format (current-error-port) + "~a:~a:~a: warning: 'title' field is deprecated~%" + file line column) + #t))))) + +;; Helper for 'process-file-system-declaration'. +(define-syntax device-expression + (syntax-rules (quote label uuid device) + ((_ (quote label) dev) + (file-system-label dev)) + ((_ (quote uuid) dev) + (if (uuid? dev) dev (uuid dev))) + ((_ (quote device) dev) + dev) + ((_ title dev) + (case title + ((label) (file-system-label dev)) + ((uuid) (uuid dev)) + (else dev))))) + +;; Helper to interpret the now-deprecated 'title' field. Detect forms like +;; (title 'label), remove them, and adjust the 'device' field accordingly. +;; TODO: Remove this once 'title' has been deprecated long enough. +(define-syntax process-file-system-declaration + (syntax-rules (device title) + ((_ () (rest ...) #f #f) ;no 'title' and no 'device' field + (%file-system rest ...)) + ((_ () (rest ...) dev #f) ;no 'title' field + (%file-system rest ... (device dev))) + ((_ () (rest ...) dev titl) ;got a 'title' field + (%file-system rest ... + (device (device-expression titl dev)))) + ((_ ((title titl) rest ...) (previous ...) dev _) + (begin + (report-deprecation (title titl)) + (process-file-system-declaration (rest ...) + (previous ...) + dev titl))) + ((_ ((device dev) rest ...) (previous ...) _ titl) + (process-file-system-declaration (rest ...) + (previous ...) + dev titl)) + ((_ (field rest ...) (previous ...) dev titl) + (process-file-system-declaration (rest ...) + (previous ... field) + dev titl)))) + +(define-syntax-rule (file-system fields ...) + (process-file-system-declaration (fields ...) () #f #f)) + +(define (file-system-title fs) ;deprecated + (match (file-system-device fs) + ((? file-system-label?) 'label) + ((? uuid?) 'uuid) + ((? string?) 'device))) + ;; Note: This module is used both on the build side and on the host side. ;; Arrange not to pull (guix store) and (guix config) because the latter ;; differs from user to user. @@ -161,23 +241,26 @@ store--e.g., if FS is the root file system." "Return a list corresponding to file-system FS that can be passed to the initrd code." (match fs - (($ <file-system> device title mount-point type flags options _ _ check?) - (list (if (uuid? device) - `(uuid ,(uuid-type device) ,(uuid-bytevector device)) - device) - title mount-point type flags options check?)))) + (($ <file-system> device mount-point type flags options _ _ check?) + (list (cond ((uuid? device) + `(uuid ,(uuid-type device) ,(uuid-bytevector device))) + ((file-system-label? device) + `(file-system-label ,(file-system-label->string device))) + (else device)) + mount-point type flags options check?)))) (define (spec->file-system sexp) "Deserialize SEXP, a list, to the corresponding <file-system> object." (match sexp - ((device title mount-point type flags options check?) + ((device mount-point type flags options check?) (file-system (device (match device (('uuid (? symbol? type) (? bytevector? bv)) (bytevector->uuid bv type)) + (('file-system-label (? string? label)) + (file-system-label label)) (_ device))) - (title title) (mount-point mount-point) (type type) (flags flags) (options options) (check? check?))))) diff --git a/gnu/system/install.scm b/gnu/system/install.scm index 920d215272..35f4ba9c24 100644 --- a/gnu/system/install.scm +++ b/gnu/system/install.scm @@ -49,7 +49,12 @@ a20-olinuxino-micro-installation-os banana-pi-m2-ultra-installation-os beaglebone-black-installation-os - nintendo-nes-classic-edition-installation-os)) + mx6cuboxi-installation-os + nintendo-nes-classic-edition-installation-os + novena-installation-os + pine64-plus-installation-os + rk3399-puma-installation-os + wandboard-installation-os)) ;;; Commentary: ;;; @@ -324,8 +329,7 @@ You have been warned. Thanks for being so brave.\x1b[0m ;; the appropriate one. (cons* (file-system (mount-point "/") - (device "GuixSD_image") - (title 'label) + (device (file-system-label "GuixSD_image")) (type "ext4")) ;; Make /tmp a tmpfs instead of keeping the overlayfs. This @@ -337,7 +341,6 @@ You have been warned. Thanks for being so brave.\x1b[0m (file-system (mount-point "/tmp") (device "none") - (title 'device) (type "tmpfs") (check? #f)) @@ -429,11 +432,36 @@ The bootloader BOOTLOADER is installed to BOOTLOADER-TARGET." "/dev/mmcblk1" ; eMMC storage "ttyS0")) +(define mx6cuboxi-installation-os + (embedded-installation-os u-boot-mx6cuboxi-bootloader + "/dev/mmcblk0" ; SD card storage + "ttymxc0")) + +(define novena-installation-os + (embedded-installation-os u-boot-novena-bootloader + "/dev/mmcblk1" ; SD card storage + "ttymxc1")) + (define nintendo-nes-classic-edition-installation-os (embedded-installation-os u-boot-nintendo-nes-classic-edition-bootloader "/dev/mmcblk0" ; SD card (solder it yourself) "ttyS0")) +(define pine64-plus-installation-os + (embedded-installation-os u-boot-pine64-plus-bootloader + "/dev/mmcblk0" ; SD card storage + "ttyS0")) + +(define rk3399-puma-installation-os + (embedded-installation-os u-boot-puma-rk3399-bootloader + "/dev/mmcblk0" ; SD card storage + "ttyS0")) + +(define wandboard-installation-os + (embedded-installation-os u-boot-wandboard-bootloader + "/dev/mmcblk0" ; SD card storage + "ttymxc0")) + ;; Return the default os here so 'guix system' can consume it directly. installation-os diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index e0cb59c009..d73ebfd8d3 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -283,7 +283,7 @@ FILE-SYSTEMS." (define virtio-modules ;; Modules for Linux para-virtualized devices, for use in QEMU guests. '("virtio_pci" "virtio_balloon" "virtio_blk" "virtio_net" - "virtio_console")) + "virtio_console" "virtio-rng")) `("ahci" ;for SATA controllers "usb-storage" "uas" ;for the installation image etc. diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm index ef5b8dab92..28d399f2b1 100644 --- a/gnu/system/shadow.scm +++ b/gnu/system/shadow.scm @@ -168,6 +168,9 @@ then return fi +# Source the system-wide file. +source /etc/bashrc + # Adjust the prompt depending on whether we're in 'guix environment'. if [ -n \"$GUIX_ENVIRONMENT\" ] then diff --git a/gnu/system/uuid.scm b/gnu/system/uuid.scm index 73695ddeb8..f13960c3e9 100644 --- a/gnu/system/uuid.scm +++ b/gnu/system/uuid.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Danny Milosavljevic <dannym@scratchpost.org> ;;; ;;; This file is part of GNU Guix. @@ -251,7 +251,8 @@ corresponding bytevector; otherwise return #f." (define-syntax uuid (lambda (s) - "Return the UUID object corresponding to the given UUID representation." + "Return the UUID object corresponding to the given UUID representation or +#f if the string could not be parsed." (syntax-case s (quote) ((_ str (quote type)) (and (string? (syntax->datum #'str)) @@ -266,9 +267,11 @@ corresponding bytevector; otherwise return #f." (string? (syntax->datum #'str)) #'(uuid str 'dce)) ((_ str) - #'(make-uuid 'dce (string->uuid str 'dce))) + #'(let ((bv (string->uuid str 'dce))) + (and bv (make-uuid 'dce bv)))) ((_ str type) - #'(make-uuid type (string->uuid str type)))))) + #'(let ((bv (string->uuid str type))) + (and bv (make-uuid type bv))))))) (define uuid->string ;; Convert the given bytevector or UUID object, to the corresponding UUID diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 09a11af863..544c0e294d 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -23,7 +23,6 @@ (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) @@ -126,6 +125,8 @@ (env-vars '()) (guile-for-build (%guile-for-build)) + (file-systems + %linux-vm-file-systems) (single-file-output? #f) (make-disk-image? #f) @@ -135,8 +136,9 @@ (disk-image-size 'guess)) "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. @@ -156,7 +158,7 @@ made available under the /xchg CIFS share." (coreutils -> (canonical-package coreutils)) (initrd (if initrd ; use the default initrd? (return initrd) - (base-initrd %linux-vm-file-systems + (base-initrd file-systems #:on-error 'backtrace #:linux linux #:linux-modules %base-initrd-modules @@ -258,6 +260,14 @@ INPUTS is a list of inputs (as for packages)." uuid-bytevector)) (reboot)))) #:system system + + ;; 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)) @@ -411,58 +421,57 @@ should set REGISTER-CLOSURES? to #f." (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")) (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 (list guile-json) ;for (guix docker) + (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 + (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 -> "")))))))) (expression->derivation-in-linux-vm name ;; The VM's initrd Guile doesn't support dlopen, but our "build" gexp @@ -571,7 +580,6 @@ to USB sticks meant to be read-only." (file-systems (cons (file-system (mount-point "/") (device root-uuid) - (title 'uuid) (type file-system-type)) file-systems-to-keep))))) @@ -636,7 +644,6 @@ of the GNU system as described by OS." (file-systems (cons (file-system (mount-point "/") (device root-uuid) - (title 'uuid) (type file-system-type)) file-systems-to-keep))))) (mlet* %store-monad @@ -693,13 +700,12 @@ environment with the store shared with the host. MAPPINGS is a list of (source (file-system-device fs))) (or (string=? target (%store-prefix)) (string=? target "/") - (and (eq? 'device (file-system-title fs)) + (and (string? source) (string-prefix? "/dev/" source)) ;; Labels and UUIDs are necessarily invalid in the VM. (and (file-system-mount? fs) - (or (eq? 'label (file-system-title fs)) - (eq? 'uuid (file-system-title fs)) + (or (file-system-label? source) (uuid? source)))))) (operating-system-file-systems os))) @@ -752,6 +758,10 @@ with the host. When FULL-BOOT? is true, return an image that does a complete boot sequence, bootloaded included; thus, make a disk image that contains everything the bootloader refers to: OS kernel, initrd, bootloader data, etc." + (define root-uuid + ;; 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 @@ -763,6 +773,7 @@ bootloader refers to: OS kernel, initrd, bootloader data, etc." #: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)) '()) |