diff options
Diffstat (limited to 'gnu/build')
| -rw-r--r-- | gnu/build/cross-toolchain.scm | 6 | ||||
| -rw-r--r-- | gnu/build/file-systems.scm | 58 | ||||
| -rw-r--r-- | gnu/build/linux-boot.scm | 12 | ||||
| -rw-r--r-- | gnu/build/marionette.scm | 27 | ||||
| -rw-r--r-- | gnu/build/shepherd.scm | 3 | ||||
| -rw-r--r-- | gnu/build/svg.scm | 11 | ||||
| -rw-r--r-- | gnu/build/vm.scm | 16 |
7 files changed, 70 insertions, 63 deletions
diff --git a/gnu/build/cross-toolchain.scm b/gnu/build/cross-toolchain.scm index 450443ca63..d430b8afc4 100644 --- a/gnu/build/cross-toolchain.scm +++ b/gnu/build/cross-toolchain.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> -;;; Copyright © 2014, 2015 Mark H Weaver <mhw@netris.org> +;;; Copyright © 2014, 2015, 2018 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2016 Manolis Fragkiskos Ragkousis <manolis837@gmail.com> ;;; @@ -119,7 +119,7 @@ C_*INCLUDE_PATH." ;; libc is false, so we are building xgcc-sans-libc. ;; Add essential headers from mingw-w64. (let ((mingw-source (assoc-ref inputs "mingw-source"))) - (system* "tar" "xvf" mingw-source) + (invoke "tar" "xvf" mingw-source) (let ((mingw-headers (unpacked-mingw-dir))) ;; We need _mingw.h which will gets built from _mingw.h.in by ;; mingw-w64's configure. We cannot configure mingw-w64 until we @@ -160,7 +160,7 @@ C_*INCLUDE_PATH." "Install a stripped GCC." ;; Unlike our 'strip' phase, this will do the right thing for ;; cross-compilers. - (zero? (system* "make" "install-strip"))) + (invoke "make" "install-strip")) (define* (cross-gcc-build-phases target #:optional (phases %standard-phases)) diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index 145b3b14e7..3f97afeedd 100644 --- a/gnu/build/file-systems.scm +++ b/gnu/build/file-systems.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016, 2017 David Craven <david@craven.ch> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; @@ -473,17 +473,9 @@ were found." (find-partition luks-partition-uuid-predicate)) -(define* (canonicalize-device-spec spec #:optional (title 'any)) - "Return the device name corresponding to SPEC. TITLE is a symbol, one of -the following: - - • 'device', in which case SPEC is known to designate a device node--e.g., - \"/dev/sda1\"; - • 'label', in which case SPEC is known to designate a partition label--e.g., - \"my-root-part\"; - • 'uuid', in which case SPEC must be a UUID designating a partition; - • 'any', in which case SPEC can be anything. -" +(define (canonicalize-device-spec spec) + "Return the device name corresponding to SPEC, which can be a <uuid>, a +<file-system-label>, or a string (typically a /dev file name)." (define max-trials ;; Number of times we retry partition label resolution, 1 second per ;; trial. Note: somebody reported a delay of 16 seconds (!) before their @@ -491,19 +483,6 @@ the following: ;; this long. 20) - (define canonical-title - ;; The realm of canonicalization. - (if (eq? title 'any) - (if (string? spec) - ;; The "--root=SPEC" kernel command-line option always provides a - ;; string, but the string can represent a device, a UUID, or a - ;; label. So check for all three. - (cond ((string-prefix? "/" spec) 'device) - ((string->uuid spec) 'uuid) - (else 'label)) - 'uuid) - title)) - (define (resolve find-partition spec fmt) (let loop ((count 0)) (let ((device (find-partition spec))) @@ -518,23 +497,19 @@ the following: (sleep 1) (loop (+ 1 count)))))))) - (case canonical-title - ((device) - ;; Nothing to do. - spec) - ((label) + (match spec + ((? string?) + ;; Nothing to do, but wait until SPEC shows up. + (resolve identity spec identity)) + ((? file-system-label?) ;; Resolve the label. - (resolve find-partition-by-label spec identity)) - ((uuid) + (resolve find-partition-by-label + (file-system-label->string spec) + identity)) + ((? uuid?) (resolve find-partition-by-uuid - (cond ((string? spec) - (string->uuid spec)) - ((uuid? spec) - (uuid-bytevector spec)) - (else spec)) - uuid->string)) - (else - (error "unknown device title" title)))) + (uuid-bytevector spec) + uuid->string)))) (define (check-file-system device type) "Run a file system check of TYPE on DEVICE." @@ -615,8 +590,7 @@ run a file system check." ""))))) (let ((type (file-system-type fs)) (options (file-system-options fs)) - (source (canonicalize-device-spec (file-system-device fs) - (file-system-title fs))) + (source (canonicalize-device-spec (file-system-device fs))) (mount-point (string-append root "/" (file-system-mount-point fs))) (flags (mount-flags->bit-mask (file-system-flags fs)))) diff --git a/gnu/build/linux-boot.scm b/gnu/build/linux-boot.scm index 18d87260a9..44b3506284 100644 --- a/gnu/build/linux-boot.scm +++ b/gnu/build/linux-boot.scm @@ -507,9 +507,15 @@ upon error." (error "pre-mount actions failed"))) (if root - (mount-root-file-system (canonicalize-device-spec root) - root-fs-type - #:volatile-root? volatile-root?) + ;; The "--root=SPEC" kernel command-line option always provides a + ;; string, but the string can represent a device, a UUID, or a + ;; label. So check for all three. + (let ((root (cond ((string-prefix? "/" root) root) + ((uuid root) => identity) + (else (file-system-label root))))) + (mount-root-file-system (canonicalize-device-spec root) + root-fs-type + #:volatile-root? volatile-root?)) (mount "none" "/root" "tmpfs")) ;; Mount the specified file systems. diff --git a/gnu/build/marionette.scm b/gnu/build/marionette.scm index 173a67cef9..bb018fc9c1 100644 --- a/gnu/build/marionette.scm +++ b/gnu/build/marionette.scm @@ -26,6 +26,7 @@ make-marionette marionette-eval wait-for-file + wait-for-tcp-port marionette-control marionette-screen-text wait-for-screen-text @@ -187,6 +188,32 @@ FILE has not shown up after TIMEOUT seconds, raise an error." ('failure (error "file didn't show up" file)))) +(define* (wait-for-tcp-port port marionette + #:key (timeout 20)) + "Wait for up to TIMEOUT seconds for PORT to accept connections in +MARIONETTE. Raise an error on failure." + ;; Note: The 'connect' loop has to run within the guest because, when we + ;; forward ports to the host, connecting to the host never raises + ;; ECONNREFUSED. + (match (marionette-eval + `(begin + (let ((sock (socket PF_INET SOCK_STREAM 0))) + (let loop ((i 0)) + (catch 'system-error + (lambda () + (connect sock AF_INET INADDR_LOOPBACK ,port) + 'success) + (lambda args + (if (< i ,timeout) + (begin + (sleep 1) + (loop (+ 1 i))) + 'failure)))))) + marionette) + ('success #t) + ('failure + (error "nobody's listening on port" port)))) + (define (marionette-control command marionette) "Run COMMAND in the QEMU monitor of MARIONETTE. COMMAND is a string such as \"sendkey ctrl-alt-f1\" or \"screendump foo.ppm\" (info \"(qemu-doc) diff --git a/gnu/build/shepherd.scm b/gnu/build/shepherd.scm index c955e3c83f..f383259924 100644 --- a/gnu/build/shepherd.scm +++ b/gnu/build/shepherd.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -55,7 +55,6 @@ (define (tmpfs directory) (file-system (device "none") - (title 'device) (mount-point directory) (type "tmpfs") (check? #f))) diff --git a/gnu/build/svg.scm b/gnu/build/svg.scm index b5474ec4a0..6f1f4b3684 100644 --- a/gnu/build/svg.scm +++ b/gnu/build/svg.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 © 2015 Andy Wingo <wingo@igalia.com> ;;; ;;; This file is part of GNU Guix. @@ -18,16 +18,11 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (gnu build svg) + #:use-module (rsvg) + #:use-module (cairo) #:use-module (srfi srfi-11) #:export (svg->png)) -;; We need Guile-RSVG and Guile-Cairo. Load them lazily, at run time, to -;; allow compilation to proceed. See also <http://bugs.gnu.org/12202>. -(module-autoload! (current-module) - '(rsvg) '(rsvg-handle-new-from-file)) -(module-autoload! (current-module) - '(cairo) '(cairo-image-surface-create)) - (define* (downscaled-surface surface #:key source-width source-height diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm index 527b4c495d..fa3ce7790d 100644 --- a/gnu/build/vm.scm +++ b/gnu/build/vm.scm @@ -106,11 +106,16 @@ the #:references-graphs parameter of 'derivation'." (not target-arm32?)) '("-enable-kvm") '()) + + ;; Pass "panic=1" so that the guest dies upon error. "-append" - ;; The serial port name differs between emulated architectures/machines. - ,@(if target-arm32? - `(,(string-append "console=ttyAMA0 --load=" builder)) - `(,(string-append "console=ttyS0 --load=" builder))) + ,(string-append "panic=1 --load=" builder + + ;; The serial port name differs between emulated + ;; architectures/machines. + " console=" + (if target-arm32? "ttyAMA0" "ttyS0")) + ;; NIC is not supported on ARM "virt" machine, so use a user mode ;; network stack instead. ,@(if target-arm32? @@ -265,7 +270,8 @@ actual /dev name based on DEVICE." #:key label uuid) "Create an ext-family file system of TYPE on PARTITION. If LABEL is true, use that as the volume name. If UUID is true, use it as the partition UUID." - (format #t "creating ~a partition...\n" type) + (format #t "creating ~a partition... ~@[label: ~s~] ~@[uuid: ~s~]\n" + type label (and uuid (uuid->string uuid))) (apply invoke (string-append "mkfs." type) "-F" partition `(,@(if label |