From 6453915cf7729203ef9552c13cb4528c6f4ed122 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Mon, 21 Sep 2020 10:11:17 +0200 Subject: build: shepherd: Check for container support. Fixes: . * gnu/build/shepherd.scm (fork+exec-command/container): Check if containers are supported before joining PID namespaces. --- gnu/build/shepherd.scm | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) (limited to 'gnu/build') diff --git a/gnu/build/shepherd.scm b/gnu/build/shepherd.scm index 65141bd60f..91646288d5 100644 --- a/gnu/build/shepherd.scm +++ b/gnu/build/shepherd.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017, 2018, 2019, 2020 Ludovic Courtès +;;; Copyright © 2020 Mathieu Othacehe ;;; ;;; This file is part of GNU Guix. ;;; @@ -196,11 +197,16 @@ namespace, in addition to essential bind-mounts such /proc." #:allow-other-keys #:rest args) "This is a variant of 'fork+exec-command' procedure, that joins the -namespaces of process PID beforehand." - (container-excursion* pid - (lambda () - (apply fork+exec-command command - (strip-keyword-arguments '(#:pid) args))))) +namespaces of process PID beforehand. If there is no support for containers, +on Hurd systems for instance, fallback to direct forking." + (let ((container-support? + (file-exists? "/proc/self/ns")) + (fork-proc (lambda () + (apply fork+exec-command command + (strip-keyword-arguments '(#:pid) args))))) + (if container-support? + (container-excursion* pid fork-proc) + (fork-proc)))) ;; Local Variables: ;; eval: (put 'container-excursion* 'scheme-indent-function 1) -- cgit v1.2.3 From f441e3e8b5fbc2406fa924d3761774bbd50cc683 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Tue, 29 Sep 2020 11:37:19 +0200 Subject: image: Add support for compressed-qcow2 format. * gnu/build/image.scm (convert-disk-image): New procedure. (genimage): Remove target argument. * gnu/system/image.scm (system-disk-image): Add support for 'compressed-qcow2 image format. Call "convert-disk-image" to apply image conversions on the final image. Add "qemu-minimal" to the build inputs. (system-image): Also add support for 'compressed-qcow2. --- gnu/build/image.scm | 16 +++++++++++++--- gnu/system/image.scm | 30 ++++++++++++++++-------------- 2 files changed, 29 insertions(+), 17 deletions(-) (limited to 'gnu/build') diff --git a/gnu/build/image.scm b/gnu/build/image.scm index d8efa73f16..8a2d0eb5fd 100644 --- a/gnu/build/image.scm +++ b/gnu/build/image.scm @@ -37,6 +37,7 @@ #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:export (make-partition-image + convert-disk-image genimage initialize-efi-partition initialize-root-partition @@ -120,13 +121,22 @@ ROOT directory to populate the image." (format (current-error-port) "Unsupported partition type~%."))))) -(define* (genimage config target) +(define (convert-disk-image image format output) + "Convert IMAGE to OUTPUT according to the given FORMAT." + (case format + ((compressed-qcow2) + (begin + (invoke "qemu-img" "convert" "-c" "-f" "raw" + "-O" "qcow2" image output))) + (else + (copy-file image output)))) + +(define* (genimage config) "Use genimage to generate in TARGET directory, the image described in the given CONFIG file." ;; genimage needs a 'root' directory. (mkdir "root") - (invoke "genimage" "--config" config - "--outputpath" target)) + (invoke "genimage" "--config" config)) (define* (register-closure prefix closure #:key diff --git a/gnu/system/image.scm b/gnu/system/image.scm index 49cdd9e7de..0f2fb62a6b 100644 --- a/gnu/system/image.scm +++ b/gnu/system/image.scm @@ -47,11 +47,13 @@ #:use-module (gnu packages hurd) #:use-module (gnu packages linux) #:use-module (gnu packages mtools) + #:use-module (gnu packages virtualization) #:use-module ((srfi srfi-1) #:prefix srfi-1:) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-35) #:use-module (rnrs bytevectors) + #:use-module (ice-9 format) #:use-module (ice-9 match) #:export (root-offset root-label @@ -207,8 +209,8 @@ used in the image." (define (format->image-type format) ;; Return the genimage format corresponding to FORMAT. For now, only ;; the hdimage format (raw disk-image) is supported. - (case format - ((disk-image) "hdimage") + (cond + ((memq format '(disk-image compressed-qcow2)) "hdimage") (else (raise (condition (&message @@ -306,25 +308,24 @@ image ~a { (name (if image-name (symbol->string image-name) name)) + (format (image-format image)) (substitutable? (image-substitutable? image)) (builder (with-imported-modules* - (let ((inputs '#+(list genimage coreutils findutils)) + (let ((inputs '#+(list genimage coreutils findutils qemu-minimal)) (bootloader-installer - #+(bootloader-disk-image-installer bootloader))) + #+(bootloader-disk-image-installer bootloader)) + (out-image (string-append "images/" #$genimage-name))) (set-path-environment-variable "PATH" '("bin" "sbin") inputs) - (genimage #$(image->genimage-cfg image) #$output) + (genimage #$(image->genimage-cfg image)) ;; Install the bootloader directly on the disk-image. (when bootloader-installer (bootloader-installer #+(bootloader-package bootloader) #$(root-partition-index image) - (string-append #$output "/" #$genimage-name)))))) - (image-dir (computed-file "image-dir" builder))) - (computed-file name - #~(symlink - (string-append #$image-dir "/" #$genimage-name) - #$output) + out-image)) + (convert-disk-image out-image '#$format #$output))))) + (computed-file name builder #:options `(#:substitutable? ,substitutable?)))) @@ -523,19 +524,20 @@ image, depending on IMAGE format." (with-parameters ((%current-target-system target)) (let* ((os (operating-system-for-image image)) (image* (image-with-os image os)) + (image-format (image-format image)) (register-closures? (has-guix-service-type? os)) (bootcfg (operating-system-bootcfg os)) (bootloader (bootloader-configuration-bootloader (operating-system-bootloader os)))) - (case (image-format image) - ((disk-image) + (cond + ((memq image-format '(disk-image compressed-qcow2)) (system-disk-image image* #:bootcfg bootcfg #:bootloader bootloader #:register-closures? register-closures? #:inputs `(("system" ,os) ("bootcfg" ,bootcfg)))) - ((iso9660) + ((memq image-format '(iso9660)) (system-iso9660-image image* #:bootcfg bootcfg -- cgit v1.2.3 From 118b6dbb46ff3376db7467301fe59673c042d220 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 26 Sep 2020 22:39:32 +0200 Subject: secret-service: Clarify the origin of messages. * gnu/build/secret-service.scm (secret-service-send-secrets) (secret-service-receive-secrets): Prefix messages by "secret service". --- gnu/build/secret-service.scm | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) (limited to 'gnu/build') diff --git a/gnu/build/secret-service.scm b/gnu/build/secret-service.scm index 781651e90d..aafb1684b5 100644 --- a/gnu/build/secret-service.scm +++ b/gnu/build/secret-service.scm @@ -54,11 +54,14 @@ local PORT. If connect fails, sleep 1s and retry RETRY times." (lambda (key . args) (when (zero? retry) (apply throw key args)) - (format (current-error-port) "retrying connection~%") + (format (current-error-port) + "secret service: retrying connection [~a attempts left]~%" + (- retry 1)) (sleep 1) (loop (1- retry))))) - (format (current-error-port) "connected! sending files in ~s %~" + (format (current-error-port) + "secret service: connected; sending files in ~s~%" secret-root) (let* ((files (if secret-root (find-files secret-root) '())) (files-sizes-modes (map file->file+size+mode files)) @@ -82,11 +85,12 @@ Write them to the file system." (bind sock AF_INET INADDR_ANY port) (listen sock 1) (format (current-error-port) - "waiting for secrets on port ~a...~%" + "secret service: waiting for secrets on port ~a...~%" port) (match (accept sock) ((client . address) - (format (current-error-port) "client connection from ~a~%" + (format (current-error-port) + "secret service: client connection from ~a~%" (inet-ntop (sockaddr:fam address) (sockaddr:addr address))) (close-port sock) @@ -116,7 +120,8 @@ Write them to the file system." ('files ((files sizes modes) ...))) (for-each (lambda (file size mode) (format (current-error-port) - "installing file '~a' (~a bytes)...~%" + "secret service: \ +installing file '~a' (~a bytes)...~%" file size) (mkdir-p (dirname file)) (call-with-output-file file @@ -126,7 +131,7 @@ Write them to the file system." files sizes modes)) (_ (format (current-error-port) - "invalid secrets received~%") + "secret service: invalid secrets received~%") #f))) (let* ((port (wait-for-client port)) -- cgit v1.2.3 From 4d047853da76dc5fa5dd50ecb750c861342ef47b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 27 Sep 2020 17:21:16 +0200 Subject: secret-service: Add a timeout when waiting for a client. * gnu/build/secret-service.scm (secret-service-receive-secrets) [wait-for-client]: Call 'select' with a 60s timeout before 'accept'. Return #f upon timeout. [read-secrets]: Return FILES on success. Adjust caller of 'wait-for-client' to handle #f. --- gnu/build/secret-service.scm | 33 +++++++++++++++++++++------------ 1 file changed, 21 insertions(+), 12 deletions(-) (limited to 'gnu/build') diff --git a/gnu/build/secret-service.scm b/gnu/build/secret-service.scm index aafb1684b5..40c24abf09 100644 --- a/gnu/build/secret-service.scm +++ b/gnu/build/secret-service.scm @@ -75,7 +75,8 @@ local PORT. If connect fails, sleep 1s and retry RETRY times." (define (secret-service-receive-secrets port) "Listen to local PORT and wait for a secret service client to send secrets. -Write them to the file system." +Write them to the file system. Return the list of files installed on success, +and #f otherwise." (define (wait-for-client port) ;; Wait for a TCP connection on PORT. Note: We cannot use the @@ -87,14 +88,20 @@ Write them to the file system." (format (current-error-port) "secret service: waiting for secrets on port ~a...~%" port) - (match (accept sock) - ((client . address) + (match (select (list sock) '() '() 60) + (((_) () ()) + (match (accept sock) + ((client . address) + (format (current-error-port) + "secret service: client connection from ~a~%" + (inet-ntop (sockaddr:fam address) + (sockaddr:addr address))) + (close-port sock) + client))) + ((() () ()) (format (current-error-port) - "secret service: client connection from ~a~%" - (inet-ntop (sockaddr:fam address) - (sockaddr:addr address))) - (close-port sock) - client)))) + "secret service: did not receive any secrets; time out~%") + #f)))) ;; TODO: Remove when (@ (guix build utils) dump-port) has a 'size' ;; parameter. @@ -128,15 +135,17 @@ installing file '~a' (~a bytes)...~%" (lambda (output) (dump port output size) (chmod file mode)))) - files sizes modes)) + files sizes modes) + files) (_ (format (current-error-port) "secret service: invalid secrets received~%") #f))) - (let* ((port (wait-for-client port)) - (result (read-secrets port))) - (close-port port) + (let* ((port (wait-for-client port)) + (result (and=> port read-secrets))) + (when port + (close-port port)) result)) ;;; secret-service.scm ends here -- cgit v1.2.3 From f9090015c58e6f47be74fe6116ef10a90378a899 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 29 Sep 2020 09:35:35 +0200 Subject: secret-service: Fix file port leak in 'secret-service-send-secrets'. * gnu/build/secret-service.scm (secret-service-send-secrets): Use 'call-with-input-file' instead of 'open-input-file'. --- gnu/build/secret-service.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'gnu/build') diff --git a/gnu/build/secret-service.scm b/gnu/build/secret-service.scm index 40c24abf09..6697e6e1b0 100644 --- a/gnu/build/secret-service.scm +++ b/gnu/build/secret-service.scm @@ -69,8 +69,10 @@ local PORT. If connect fails, sleep 1s and retry RETRY times." (version 0) (files ,files-sizes-modes)))) (write secrets sock) - (for-each (compose (cute dump-port <> sock) - (cute open-input-file <>)) + (for-each (lambda (file) + (call-with-input-file file + (lambda (input) + (dump-port input sock)))) files)))) (define (secret-service-receive-secrets port) -- cgit v1.2.3 From 59261a22f9819b1fdf797ffba17af17d385d6c92 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 29 Sep 2020 11:45:55 +0200 Subject: services: secret-service: Add initial client/server handshake. This allows the client running on the host to know when it's actually connect to the server running in the guest. Failing that, the client would connect right away to QEMU and send secrets even though the server is not running yet in the guest, which is unreliable. * gnu/build/secret-service.scm (secret-service-send-secrets): Add #:handshake-timeout. Read from SOCK an initial message from the server. Return #f on error. (secret-service-receive-secrets): Send 'secret-service-server' message to the client. Close SOCK upon timeout. * gnu/services/virtualization.scm (hurd-vm-shepherd-service): 'start' method returns #f when 'secret-service-send-secrets' returns #f. --- gnu/build/secret-service.scm | 75 +++++++++++++++++++++++++++++++---------- gnu/services/virtualization.scm | 11 ++++-- 2 files changed, 67 insertions(+), 19 deletions(-) (limited to 'gnu/build') diff --git a/gnu/build/secret-service.scm b/gnu/build/secret-service.scm index 6697e6e1b0..2cc59e0ee1 100644 --- a/gnu/build/secret-service.scm +++ b/gnu/build/secret-service.scm @@ -35,19 +35,37 @@ ;;; ;;; Code: -(define* (secret-service-send-secrets port secret-root #:key (retry 60)) +(define* (secret-service-send-secrets port secret-root + #:key (retry 60) + (handshake-timeout 120)) "Copy all files under SECRET-ROOT using TCP to secret-service listening at -local PORT. If connect fails, sleep 1s and retry RETRY times." - +local PORT. If connect fails, sleep 1s and retry RETRY times; once connected, +wait for at most HANDSHAKE-TIMEOUT seconds for handshake to complete. Return +#f on failure." (define (file->file+size+mode file-name) (let ((stat (stat file-name)) (target (substring file-name (string-length secret-root)))) (list target (stat:size stat) (stat:mode stat)))) + (define (send-files sock) + (let* ((files (if secret-root (find-files secret-root) '())) + (files-sizes-modes (map file->file+size+mode files)) + (secrets `(secrets + (version 0) + (files ,files-sizes-modes)))) + (write secrets sock) + (for-each (lambda (file) + (call-with-input-file file + (lambda (input) + (dump-port input sock)))) + files))) + (format (current-error-port) "sending secrets to ~a~%" port) (let ((sock (socket AF_INET SOCK_STREAM 0)) (addr (make-socket-address AF_INET INADDR_LOOPBACK port))) - ;; connect to wait for port + ;; Connect to QEMU on the forwarded port. The 'connect' call succeeds as + ;; soon as QEMU is ready, even if there's no server listening on the + ;; forward port inside the guest. (let loop ((retry retry)) (catch 'system-error (cute connect sock addr) @@ -61,19 +79,35 @@ local PORT. If connect fails, sleep 1s and retry RETRY times." (loop (1- retry))))) (format (current-error-port) - "secret service: connected; sending files in ~s~%" - secret-root) - (let* ((files (if secret-root (find-files secret-root) '())) - (files-sizes-modes (map file->file+size+mode files)) - (secrets `(secrets - (version 0) - (files ,files-sizes-modes)))) - (write secrets sock) - (for-each (lambda (file) - (call-with-input-file file - (lambda (input) - (dump-port input sock)))) - files)))) + "secret service: connected; waiting for handshake...~%") + + ;; Wait for "hello" message from the server. This is the only way to know + ;; that we're really connected to the server inside the guest. + (match (select (list sock) '() '() handshake-timeout) + (((_) () ()) + (match (read sock) + (('secret-service-server ('version version ...)) + (format (current-error-port) + "secret service: sending files from ~s...~%" + secret-root) + (send-files sock) + (format (current-error-port) + "secret service: done sending files to port ~a~%" + port) + (close-port sock) + secret-root) + (x + (format (current-error-port) + "secret service: invalid handshake ~s~%" + x) + (close-port sock) + #f))) + ((() () ()) ;timeout + (format (current-error-port) + "secret service: timeout while sending files to ~a~%" + port) + (close-port sock) + #f)))) (define (secret-service-receive-secrets port) "Listen to local PORT and wait for a secret service client to send secrets. @@ -98,11 +132,18 @@ and #f otherwise." "secret service: client connection from ~a~%" (inet-ntop (sockaddr:fam address) (sockaddr:addr address))) + + ;; Send a "hello" message. This allows the client running on the + ;; host to know that it's now actually connected to server running + ;; in the guest. + (write '(secret-service-server (version 0)) client) + (force-output client) (close-port sock) client))) ((() () ()) (format (current-error-port) "secret service: did not receive any secrets; time out~%") + (close-port sock) #f)))) ;; TODO: Remove when (@ (guix build utils) dump-port) has a 'size' diff --git a/gnu/services/virtualization.scm b/gnu/services/virtualization.scm index 2410be450b..7e2f5a1490 100644 --- a/gnu/services/virtualization.scm +++ b/gnu/services/virtualization.scm @@ -982,8 +982,15 @@ is added to the OS specified in CONFIG." (root #$(hurd-vm-configuration-secret-root config))) (catch #t (lambda _ - (secret-service-send-secrets port root) - pid) + ;; XXX: 'secret-service-send-secrets' won't complete until + ;; the guest has booted and its secret service server is + ;; running, which could take 20+ seconds during which PID 1 + ;; is stuck waiting. + (if (secret-service-send-secrets port root) + pid + (begin + (kill (- pid) SIGTERM) + #f))) (lambda (key . args) (kill (- pid) SIGTERM) (apply throw key args))))))) -- cgit v1.2.3 From d5366500ec1aeecad6fc292b195088e30aa715fd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 29 Sep 2020 12:02:09 +0200 Subject: secret-service: Add proper logging procedure and log to syslog. * gnu/build/secret-service.scm (log): New macro. (secret-service-send-secrets, secret-service-receive-secrets): Use it instead of raw 'format' calls. --- gnu/build/secret-service.scm | 62 +++++++++++++++++++++----------------------- 1 file changed, 29 insertions(+), 33 deletions(-) (limited to 'gnu/build') diff --git a/gnu/build/secret-service.scm b/gnu/build/secret-service.scm index 2cc59e0ee1..46dcf1b9c3 100644 --- a/gnu/build/secret-service.scm +++ b/gnu/build/secret-service.scm @@ -35,6 +35,18 @@ ;;; ;;; Code: +(define-syntax log + (lambda (s) + "Log the given message." + (syntax-case s () + ((_ fmt args ...) + (with-syntax ((fmt (string-append "secret service: " + (syntax->datum #'fmt)))) + ;; Log to the current output port. That way, when + ;; 'secret-service-send-secrets' is called from shepherd, output goes + ;; to syslog. + #'(format (current-output-port) fmt args ...)))))) + (define* (secret-service-send-secrets port secret-root #:key (retry 60) (handshake-timeout 120)) @@ -60,7 +72,7 @@ wait for at most HANDSHAKE-TIMEOUT seconds for handshake to complete. Return (dump-port input sock)))) files))) - (format (current-error-port) "sending secrets to ~a~%" port) + (log "sending secrets to ~a~%" port) (let ((sock (socket AF_INET SOCK_STREAM 0)) (addr (make-socket-address AF_INET INADDR_LOOPBACK port))) ;; Connect to QEMU on the forwarded port. The 'connect' call succeeds as @@ -72,14 +84,12 @@ wait for at most HANDSHAKE-TIMEOUT seconds for handshake to complete. Return (lambda (key . args) (when (zero? retry) (apply throw key args)) - (format (current-error-port) - "secret service: retrying connection [~a attempts left]~%" - (- retry 1)) + (log "retrying connection [~a attempts left]~%" + (- retry 1)) (sleep 1) (loop (1- retry))))) - (format (current-error-port) - "secret service: connected; waiting for handshake...~%") + (log "connected; waiting for handshake...~%") ;; Wait for "hello" message from the server. This is the only way to know ;; that we're really connected to the server inside the guest. @@ -87,25 +97,17 @@ wait for at most HANDSHAKE-TIMEOUT seconds for handshake to complete. Return (((_) () ()) (match (read sock) (('secret-service-server ('version version ...)) - (format (current-error-port) - "secret service: sending files from ~s...~%" - secret-root) + (log "sending files from ~s...~%" secret-root) (send-files sock) - (format (current-error-port) - "secret service: done sending files to port ~a~%" - port) + (log "done sending files to port ~a~%" port) (close-port sock) secret-root) (x - (format (current-error-port) - "secret service: invalid handshake ~s~%" - x) + (log "invalid handshake ~s~%" x) (close-port sock) #f))) ((() () ()) ;timeout - (format (current-error-port) - "secret service: timeout while sending files to ~a~%" - port) + (log "timeout while sending files to ~a~%" port) (close-port sock) #f)))) @@ -121,17 +123,14 @@ and #f otherwise." (let ((sock (socket AF_INET SOCK_STREAM 0))) (bind sock AF_INET INADDR_ANY port) (listen sock 1) - (format (current-error-port) - "secret service: waiting for secrets on port ~a...~%" - port) + (log "waiting for secrets on port ~a...~%" port) (match (select (list sock) '() '() 60) (((_) () ()) (match (accept sock) ((client . address) - (format (current-error-port) - "secret service: client connection from ~a~%" - (inet-ntop (sockaddr:fam address) - (sockaddr:addr address))) + (log "client connection from ~a~%" + (inet-ntop (sockaddr:fam address) + (sockaddr:addr address))) ;; Send a "hello" message. This allows the client running on the ;; host to know that it's now actually connected to server running @@ -141,8 +140,7 @@ and #f otherwise." (close-port sock) client))) ((() () ()) - (format (current-error-port) - "secret service: did not receive any secrets; time out~%") + (log "did not receive any secrets; time out~%") (close-port sock) #f)))) @@ -169,20 +167,18 @@ and #f otherwise." (('secrets ('version 0) ('files ((files sizes modes) ...))) (for-each (lambda (file size mode) - (format (current-error-port) - "secret service: \ -installing file '~a' (~a bytes)...~%" - file size) + (log "installing file '~a' (~a bytes)...~%" + file size) (mkdir-p (dirname file)) (call-with-output-file file (lambda (output) (dump port output size) (chmod file mode)))) files sizes modes) + (log "received ~a secret files~%" (length files)) files) (_ - (format (current-error-port) - "secret service: invalid secrets received~%") + (log "invalid secrets received~%") #f))) (let* ((port (wait-for-client port)) -- cgit v1.2.3 From e74818353882f187e5971b5a3a481f17df883dbe Mon Sep 17 00:00:00 2001 From: Jelle Licht Date: Tue, 29 Sep 2020 23:25:13 +0200 Subject: linux-container: Reset jailed root permissions. * gnu/build/linux-container.scm (mount-file-systems): Add 'chmod' call. * tests/containers.scm ("call-with-container, mnt namespace, root permissions"): New test. --- gnu/build/linux-container.scm | 3 ++- tests/containers.scm | 8 ++++++++ 2 files changed, 10 insertions(+), 1 deletion(-) (limited to 'gnu/build') diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm index 2d4de788df..4a8bed5a9a 100644 --- a/gnu/build/linux-container.scm +++ b/gnu/build/linux-container.scm @@ -170,7 +170,8 @@ for the process." (pivot-root root put-old) (chdir "/") (umount "real-root" MNT_DETACH) - (rmdir "real-root"))) + (rmdir "real-root") + (chmod "/" #o755))) (define* (initialize-user-namespace pid host-uids #:key (guest-uid 0) (guest-gid 0)) diff --git a/tests/containers.scm b/tests/containers.scm index 7b63e5c108..608902c41a 100644 --- a/tests/containers.scm +++ b/tests/containers.scm @@ -133,6 +133,14 @@ (lambda () (primitive-exit 0))))) +(skip-if-unsupported) +(test-assert "call-with-container, mnt namespace, root permissions" + (zero? + (call-with-container '() + (lambda () + (assert-exit (= #o755 (stat:perms (lstat "/"))))) + #:namespaces '(user mnt)))) + (skip-if-unsupported) (test-assert "container-excursion" (call-with-temporary-directory -- cgit v1.2.3 From b97b423e3f61c80d5877dadc95b3f316cd61788f Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Mon, 5 Oct 2020 10:58:55 +0200 Subject: bootloader: Fix u-boot installation. This is a follow-up of f19cf27c2b9ff92e2c0fd931ef7fde39c376adaa. The bootloader installation must be done on the final disk-image, hence using "disk-image-installer" instead of "installer" callback. * gnu/bootloader/u-boot.scm: Turn all installer callbacks into disk-image-installer callbacks. * gnu/build/bootloader.scm (write-file-on-device): Open the output file with 'no-truncate and 'no-create options. * gnu/system/image.scm (with-imported-modules*): Add (gnu build bootloader) module. --- gnu/bootloader/u-boot.scm | 69 ++++++++++++++++++++++++----------------------- gnu/build/bootloader.scm | 15 +++++++---- gnu/system/image.scm | 2 ++ 3 files changed, 47 insertions(+), 39 deletions(-) (limited to 'gnu/build') diff --git a/gnu/bootloader/u-boot.scm b/gnu/bootloader/u-boot.scm index 1da9d04eb2..c57d4964c8 100644 --- a/gnu/bootloader/u-boot.scm +++ b/gnu/bootloader/u-boot.scm @@ -45,7 +45,7 @@ u-boot-wandboard-bootloader)) (define install-u-boot - #~(lambda (bootloader device mount-point) + #~(lambda (bootloader root-index image) (if bootloader (error "Failed to install U-Boot")))) @@ -56,74 +56,74 @@ ;; the MLO and is expected at 0x60000. Write both first stage ("MLO") and ;; second stage ("u-boot.img") images, read in BOOTLOADER directory, to the ;; specified DEVICE. - #~(lambda (bootloader device mount-point) + #~(lambda (bootloader root-index image) (let ((mlo (string-append bootloader "/libexec/MLO")) (u-boot (string-append bootloader "/libexec/u-boot.img"))) (write-file-on-device mlo (* 256 512) - device (* 256 512)) + image (* 256 512)) (write-file-on-device u-boot (* 1024 512) - device (* 768 512))))) + image (* 768 512))))) (define install-allwinner-u-boot - #~(lambda (bootloader device mount-point) + #~(lambda (bootloader root-index image) (let ((u-boot (string-append bootloader "/libexec/u-boot-sunxi-with-spl.bin"))) (write-file-on-device u-boot (stat:size (stat u-boot)) - device (* 8 1024))))) + image (* 8 1024))))) (define install-allwinner64-u-boot - #~(lambda (bootloader device mount-point) + #~(lambda (bootloader root-index image) (let ((spl (string-append bootloader "/libexec/spl/sunxi-spl.bin")) (u-boot (string-append bootloader "/libexec/u-boot.itb"))) (write-file-on-device spl (stat:size (stat spl)) - device (* 8 1024)) + image (* 8 1024)) (write-file-on-device u-boot (stat:size (stat u-boot)) - device (* 40 1024))))) + image (* 40 1024))))) (define install-imx-u-boot - #~(lambda (bootloader device mount-point) + #~(lambda (bootloader root-index image) (let ((spl (string-append bootloader "/libexec/SPL")) (u-boot (string-append bootloader "/libexec/u-boot.img"))) (write-file-on-device spl (stat:size (stat spl)) - device (* 1 1024)) + image (* 1 1024)) (write-file-on-device u-boot (stat:size (stat u-boot)) - device (* 69 1024))))) + image (* 69 1024))))) (define install-puma-rk3399-u-boot - #~(lambda (bootloader device mount-point) + #~(lambda (bootloader root-index image) (let ((spl (string-append bootloader "/libexec/u-boot-spl.rksd")) (u-boot (string-append bootloader "/libexec/u-boot.itb"))) (write-file-on-device spl (stat:size (stat spl)) - device (* 64 512)) + image (* 64 512)) (write-file-on-device u-boot (stat:size (stat u-boot)) - device (* 512 512))))) + image (* 512 512))))) (define install-firefly-rk3399-u-boot - #~(lambda (bootloader device mount-point) + #~(lambda (bootloader root-index image) (let ((idb (string-append bootloader "/libexec/idbloader.img")) (u-boot (string-append bootloader "/libexec/u-boot.itb"))) (write-file-on-device idb (stat:size (stat idb)) - device (* 64 512)) + image (* 64 512)) (write-file-on-device u-boot (stat:size (stat u-boot)) - device (* 16384 512))))) + image (* 16384 512))))) (define install-rock64-rk3328-u-boot - #~(lambda (bootloader device mount-point) + #~(lambda (bootloader root-index image) (let ((idb (string-append bootloader "/libexec/idbloader.img")) (u-boot (string-append bootloader "/libexec/u-boot.itb"))) (write-file-on-device idb (stat:size (stat idb)) - device (* 64 512)) + image (* 64 512)) (write-file-on-device u-boot (stat:size (stat u-boot)) - device (* 16384 512))))) + image (* 16384 512))))) (define install-rockpro64-rk3399-u-boot - #~(lambda (bootloader device mount-point) + #~(lambda (bootloader root-index image) (let ((idb (string-append bootloader "/libexec/idbloader.img")) (u-boot (string-append bootloader "/libexec/u-boot.itb"))) (write-file-on-device idb (stat:size (stat idb)) - device (* 64 512)) + image (* 64 512)) (write-file-on-device u-boot (stat:size (stat u-boot)) - device (* 16384 512))))) + image (* 16384 512))))) (define install-pinebook-pro-rk3399-u-boot install-rockpro64-rk3399-u-boot) @@ -138,28 +138,29 @@ (inherit extlinux-bootloader) (name 'u-boot) (package #f) - (installer install-u-boot))) + (installer #f) + (disk-image-installer install-u-boot))) (define u-boot-beaglebone-black-bootloader (bootloader (inherit u-boot-bootloader) (package u-boot-am335x-boneblack) - (installer install-beaglebone-black-u-boot))) + (disk-image-installer install-beaglebone-black-u-boot))) (define u-boot-allwinner-bootloader (bootloader (inherit u-boot-bootloader) - (installer install-allwinner-u-boot))) + (disk-image-installer install-allwinner-u-boot))) (define u-boot-allwinner64-bootloader (bootloader (inherit u-boot-bootloader) - (installer install-allwinner64-u-boot))) + (disk-image-installer install-allwinner64-u-boot))) (define u-boot-imx-bootloader (bootloader (inherit u-boot-bootloader) - (installer install-imx-u-boot))) + (disk-image-installer install-imx-u-boot))) (define u-boot-nintendo-nes-classic-edition-bootloader (bootloader @@ -196,7 +197,7 @@ (bootloader (inherit u-boot-bootloader) (package u-boot-firefly-rk3399) - (installer install-firefly-rk3399-u-boot))) + (disk-image-installer install-firefly-rk3399-u-boot))) (define u-boot-mx6cuboxi-bootloader (bootloader @@ -232,25 +233,25 @@ (bootloader (inherit u-boot-bootloader) (package u-boot-puma-rk3399) - (installer install-puma-rk3399-u-boot))) + (disk-image-installer install-puma-rk3399-u-boot))) (define u-boot-rock64-rk3328-bootloader ;; SD and eMMC use the same format (bootloader (inherit u-boot-bootloader) (package u-boot-rock64-rk3328) - (installer install-rock64-rk3328-u-boot))) + (disk-image-installer install-rock64-rk3328-u-boot))) (define u-boot-rockpro64-rk3399-bootloader ;; SD and eMMC use the same format (bootloader (inherit u-boot-bootloader) (package u-boot-rockpro64-rk3399) - (installer install-rockpro64-rk3399-u-boot))) + (disk-image-installer install-rockpro64-rk3399-u-boot))) (define u-boot-pinebook-pro-rk3399-bootloader ;; SD and eMMC use the same format (bootloader (inherit u-boot-bootloader) (package u-boot-pinebook-pro-rk3399) - (installer install-pinebook-pro-rk3399-u-boot))) + (disk-image-installer install-pinebook-pro-rk3399-u-boot))) diff --git a/gnu/build/bootloader.scm b/gnu/build/bootloader.scm index 498022f6db..5ec839f902 100644 --- a/gnu/build/bootloader.scm +++ b/gnu/build/bootloader.scm @@ -22,6 +22,8 @@ #:use-module (guix utils) #:use-module (ice-9 binary-ports) #:use-module (ice-9 format) + #:use-module (rnrs io ports) + #:use-module (rnrs io simple) #:export (write-file-on-device install-efi-loader)) @@ -35,11 +37,14 @@ (call-with-input-file file (lambda (input) (let ((bv (get-bytevector-n input size))) - (call-with-output-file device - (lambda (output) - (seek output offset SEEK_SET) - (put-bytevector output bv)) - #:binary #t))))) + (call-with-port + (open-file-output-port device + (file-options no-truncate no-create) + (buffer-mode block) + (native-transcoder)) + (lambda (output) + (seek output offset SEEK_SET) + (put-bytevector output bv))))))) ;;; diff --git a/gnu/system/image.scm b/gnu/system/image.scm index d8d5882a54..2aa6c2ef13 100644 --- a/gnu/system/image.scm +++ b/gnu/system/image.scm @@ -202,6 +202,7 @@ set to the given OS." (with-imported-modules `(,@(source-module-closure '((gnu build vm) (gnu build image) + (gnu build bootloader) (gnu build hurd-boot) (gnu build linux-boot) (guix store database)) @@ -210,6 +211,7 @@ set to the given OS." #~(begin (use-modules (gnu build vm) (gnu build image) + (gnu build bootloader) (gnu build hurd-boot) (gnu build linux-boot) (guix store database) -- cgit v1.2.3 From 44e65a75886282a01001179e01bff2b9e957eb0a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 8 Oct 2020 12:15:06 +0200 Subject: hurd-boot: Create /servers/crash. * gnu/build/hurd-boot.scm (set-hurd-device-translators): Create /servers/crash. --- gnu/build/hurd-boot.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'gnu/build') diff --git a/gnu/build/hurd-boot.scm b/gnu/build/hurd-boot.scm index adc8b4ce16..45d0040e60 100644 --- a/gnu/build/hurd-boot.scm +++ b/gnu/build/hurd-boot.scm @@ -244,6 +244,7 @@ set." (false-if-EEXIST (symlink "/dev/fd/0" (scope "dev/stdin"))) (false-if-EEXIST (symlink "/dev/fd/1" (scope "dev/stdout"))) (false-if-EEXIST (symlink "/dev/fd/2" (scope "dev/stderr"))) + (false-if-EEXIST (symlink "crash-dump-core" (scope "servers/crash"))) ;; Make sure /etc/mtab is a symlink to /proc/mounts. (false-if-exception (delete-file (scope "etc/mtab"))) -- cgit v1.2.3 From 57a7aa1ae3ef67c6e8becca766adfb4b4c8f59ac Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 14 Oct 2020 11:06:55 +0200 Subject: hurd-boot: Set /hurd/magic on /dev/fd. * gnu/build/hurd-boot.scm (set-hurd-device-translators)[devices]: Add "/dev/fd". --- gnu/build/hurd-boot.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'gnu/build') diff --git a/gnu/build/hurd-boot.scm b/gnu/build/hurd-boot.scm index 45d0040e60..e66d4d1ba8 100644 --- a/gnu/build/hurd-boot.scm +++ b/gnu/build/hurd-boot.scm @@ -211,6 +211,9 @@ set." ("dev/vcs" ("/hurd/console")) ("dev/tty" ("/hurd/magic" "tty") #o666) + ;; 'fd_to_filename' in libc expects it. + ("dev/fd" ("/hurd/magic" "--directory" "fd") #o555) + ("dev/tty1" ("/hurd/term" "/dev/tty1" "hurdio" "/dev/vcs/1/console") #o666) ("dev/tty2" ("/hurd/term" "/dev/tty2" "hurdio" "/dev/vcs/2/console") @@ -240,7 +243,6 @@ set." (for-each scope-set-translator devices) (false-if-EEXIST (symlink "/dev/random" (scope "dev/urandom"))) - (mkdir* "dev/fd") (false-if-EEXIST (symlink "/dev/fd/0" (scope "dev/stdin"))) (false-if-EEXIST (symlink "/dev/fd/1" (scope "dev/stdout"))) (false-if-EEXIST (symlink "/dev/fd/2" (scope "dev/stderr"))) -- cgit v1.2.3