diff options
Diffstat (limited to 'gnu/build')
| -rw-r--r-- | gnu/build/bootloader.scm | 15 | ||||
| -rw-r--r-- | gnu/build/image.scm | 16 | ||||
| -rw-r--r-- | gnu/build/linux-container.scm | 3 | ||||
| -rw-r--r-- | gnu/build/secret-service.scm | 121 | ||||
| -rw-r--r-- | gnu/build/shepherd.scm | 16 |
5 files changed, 123 insertions, 48 deletions
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/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/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/gnu/build/secret-service.scm b/gnu/build/secret-service.scm index 781651e90d..46dcf1b9c3 100644 --- a/gnu/build/secret-service.scm +++ b/gnu/build/secret-service.scm @@ -35,44 +35,86 @@ ;;; ;;; 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-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)) + "Copy all files under SECRET-ROOT using TCP to secret-service listening at +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)))) - (format (current-error-port) "sending secrets to ~a~%" port) + (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))) + + (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 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) (lambda (key . args) (when (zero? retry) (apply throw key args)) - (format (current-error-port) "retrying connection~%") + (log "retrying connection [~a attempts left]~%" + (- retry 1)) (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)))) + (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. + (match (select (list sock) '() '() handshake-timeout) + (((_) () ()) + (match (read sock) + (('secret-service-server ('version version ...)) + (log "sending files from ~s...~%" secret-root) + (send-files sock) + (log "done sending files to port ~a~%" port) + (close-port sock) + secret-root) + (x + (log "invalid handshake ~s~%" x) + (close-port sock) + #f))) + ((() () ()) ;timeout + (log "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. -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 @@ -81,16 +123,26 @@ Write them to the file system." (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~%" + (log "waiting for secrets on port ~a...~%" port) + (match (select (list sock) '() '() 60) + (((_) () ()) + (match (accept sock) + ((client . 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 + ;; in the guest. + (write '(secret-service-server (version 0)) client) + (force-output client) + (close-port sock) + client))) + ((() () ()) + (log "did not receive any secrets; time out~%") (close-port sock) - client)))) + #f)))) ;; TODO: Remove when (@ (guix build utils) dump-port) has a 'size' ;; parameter. @@ -115,23 +167,24 @@ Write them to the file system." (('secrets ('version 0) ('files ((files sizes modes) ...))) (for-each (lambda (file size mode) - (format (current-error-port) - "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)) + files sizes modes) + (log "received ~a secret files~%" (length files)) + files) (_ - (format (current-error-port) - "invalid secrets received~%") + (log "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 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 <ludo@gnu.org> +;;; Copyright © 2020 Mathieu Othacehe <othacehe@gnu.org> ;;; ;;; 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) |