diff options
Diffstat (limited to 'gnu/build')
| -rw-r--r-- | gnu/build/file-systems.scm | 3 | ||||
| -rw-r--r-- | gnu/build/install.scm | 44 | ||||
| -rw-r--r-- | gnu/build/linux-boot.scm | 5 | ||||
| -rw-r--r-- | gnu/build/linux-container.scm | 3 | ||||
| -rw-r--r-- | gnu/build/secret-service.scm | 137 | ||||
| -rw-r--r-- | gnu/build/shepherd.scm | 18 |
6 files changed, 203 insertions, 7 deletions
diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index 4ba1503b9f..734d648575 100644 --- a/gnu/build/file-systems.scm +++ b/gnu/build/file-systems.scm @@ -675,7 +675,8 @@ were found." (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)." +<file-system-label>, or a string (typically a /dev file name or an nfs-root +containing ':/')." (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 diff --git a/gnu/build/install.scm b/gnu/build/install.scm index 87aa5d68da..63995e1d09 100644 --- a/gnu/build/install.scm +++ b/gnu/build/install.scm @@ -18,6 +18,7 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (gnu build install) + #:use-module (guix build syscalls) #:use-module (guix build utils) #:use-module (guix build store-copy) #:use-module (srfi srfi-26) @@ -26,7 +27,9 @@ evaluate-populate-directive populate-root-file-system install-database-and-gc-roots - populate-single-profile-directory)) + populate-single-profile-directory + mount-cow-store + unmount-cow-store)) ;;; Commentary: ;;; @@ -229,4 +232,43 @@ This is used to create the self-contained tarballs with 'guix pack'." (_ #t))) +(define (mount-cow-store target backing-directory) + "Make the store copy-on-write, using TARGET as the backing store. This is +useful when TARGET is on a hard disk, whereas the current store is on a RAM +disk." + (define (set-store-permissions directory) + "Set the right perms on DIRECTORY to use it as the store." + (chown directory 0 30000) ;use the fixed 'guixbuild' GID + (chmod directory #o1775)) + + (let ((tmpdir (string-append target "/tmp"))) + (mkdir-p tmpdir) + (mount tmpdir "/tmp" "none" MS_BIND)) + + (let* ((rw-dir (string-append target backing-directory)) + (work-dir (string-append rw-dir "/../.overlayfs-workdir"))) + (mkdir-p rw-dir) + (mkdir-p work-dir) + (mkdir-p "/.rw-store") + (set-store-permissions rw-dir) + (set-store-permissions "/.rw-store") + + ;; Mount the overlay, then atomically make it the store. + (mount "none" "/.rw-store" "overlay" 0 + (string-append "lowerdir=" (%store-directory) "," + "upperdir=" rw-dir "," + "workdir=" work-dir)) + (mount "/.rw-store" (%store-directory) "" MS_MOVE) + (rmdir "/.rw-store"))) + +(define (unmount-cow-store target backing-directory) + "Unmount copy-on-write store." + (let ((tmp-dir "/remove")) + (mkdir-p tmp-dir) + (mount (%store-directory) tmp-dir "" MS_MOVE) + (umount tmp-dir) + (rmdir tmp-dir) + (delete-file-recursively + (string-append target backing-directory)))) + ;;; install.scm ends here diff --git a/gnu/build/linux-boot.scm b/gnu/build/linux-boot.scm index 80fe0cfb9d..32e3536039 100644 --- a/gnu/build/linux-boot.scm +++ b/gnu/build/linux-boot.scm @@ -469,9 +469,10 @@ upon error." (define (device-string->file-system-device device-string) ;; 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. + ;; string, but the string can represent a device, an nfs-root, a UUID, or a + ;; label. So check for all four. (cond ((string-prefix? "/" device-string) device-string) + ((string-contains device-string ":/") device-string) ; nfs-root ((uuid device-string) => identity) (else (file-system-label device-string)))) diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm index 87695c98fd..2d4de788df 100644 --- a/gnu/build/linux-container.scm +++ b/gnu/build/linux-container.scm @@ -243,7 +243,8 @@ that host UIDs (respectively GIDs) map to in the namespace." (match (read child) ('ready (purify-environment) - (when (memq 'mnt namespaces) + (when (and (memq 'mnt namespaces) + (not (string=? root "/"))) (catch #t (lambda () (mount-file-systems root mounts diff --git a/gnu/build/secret-service.scm b/gnu/build/secret-service.scm new file mode 100644 index 0000000000..781651e90d --- /dev/null +++ b/gnu/build/secret-service.scm @@ -0,0 +1,137 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (gnu build secret-service) + #:use-module (guix build utils) + + #:use-module (srfi srfi-26) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 binary-ports) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + + #:export (secret-service-receive-secrets + secret-service-send-secrets)) + +;;; Commentary: +;;; +;;; Utility procedures for copying secrets into a VM. +;;; +;;; Code: + +(define* (secret-service-send-secrets port secret-root #:key (retry 60)) + "Copy all files under SECRET-ROOT using TCP to secret-service listening at +local PORT. If connect fails, sleep 1s and retry RETRY times." + + (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)))) + + (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 + (let loop ((retry retry)) + (catch 'system-error + (cute connect sock addr) + (lambda (key . args) + (when (zero? retry) + (apply throw key args)) + (format (current-error-port) "retrying connection~%") + (sleep 1) + (loop (1- retry))))) + + (format (current-error-port) "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 (compose (cute dump-port <> sock) + (cute open-input-file <>)) + files)))) + +(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." + + (define (wait-for-client port) + ;; Wait for a TCP connection on PORT. Note: We cannot use the + ;; virtio-serial ports, which would be safer, because they are + ;; (presumably) unsupported on GNU/Hurd. + (let ((sock (socket AF_INET SOCK_STREAM 0))) + (bind sock AF_INET INADDR_ANY port) + (listen sock 1) + (format (current-error-port) + "waiting for secrets on port ~a...~%" + port) + (match (accept sock) + ((client . address) + (format (current-error-port) "client connection from ~a~%" + (inet-ntop (sockaddr:fam address) + (sockaddr:addr address))) + (close-port sock) + client)))) + + ;; TODO: Remove when (@ (guix build utils) dump-port) has a 'size' + ;; parameter. + (define (dump in out size) + ;; Copy SIZE bytes from IN to OUT. + (define buf-size 65536) + (define buf (make-bytevector buf-size)) + + (let loop ((left size)) + (if (<= left 0) + 0 + (let ((read (get-bytevector-n! in buf 0 (min left buf-size)))) + (if (eof-object? read) + left + (begin + (put-bytevector out buf 0 read) + (loop (- left read)))))))) + + (define (read-secrets port) + ;; Read secret files from PORT and install them. + (match (false-if-exception (read port)) + (('secrets ('version 0) + ('files ((files sizes modes) ...))) + (for-each (lambda (file size mode) + (format (current-error-port) + "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)) + (_ + (format (current-error-port) + "invalid secrets received~%") + #f))) + + (let* ((port (wait-for-client port)) + (result (read-secrets port))) + (close-port port) + result)) + +;;; secret-service.scm ends here diff --git a/gnu/build/shepherd.scm b/gnu/build/shepherd.scm index fd93e7f3f4..65141bd60f 100644 --- a/gnu/build/shepherd.scm +++ b/gnu/build/shepherd.scm @@ -20,10 +20,12 @@ #:use-module (gnu system file-systems) #:use-module (gnu build linux-container) #:use-module (guix build utils) + #:use-module (guix utils) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (ice-9 match) - #:export (make-forkexec-constructor/container)) + #:export (make-forkexec-constructor/container + fork+exec-command/container)) ;;; Commentary: ;;; @@ -93,7 +95,8 @@ ;; XXX: Lazy-bind the Shepherd to avoid a compile-time dependency. (module-autoload! (current-module) '(shepherd service) - '(read-pid-file exec-command %precious-signals)) + '(fork+exec-command read-pid-file exec-command + %precious-signals)) (module-autoload! (current-module) '(shepherd system) '(unblock-signals)) @@ -188,6 +191,17 @@ namespace, in addition to essential bind-mounts such /proc." (read-pid-file pid-file #:max-delay pid-file-timeout)) pid)))) +(define* (fork+exec-command/container command + #:key pid + #: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))))) + ;; Local Variables: ;; eval: (put 'container-excursion* 'scheme-indent-function 1) ;; End: |