From patchwork Tue Jan 23 16:48:16 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 59346 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id DFFE027BBEA; Tue, 23 Jan 2024 16:49:21 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-3.7 required=5.0 tests=BAYES_00,DKIM_INVALID, DKIM_SIGNED,MAILING_LIST_MULTI,RCVD_IN_MSPIKE_H5,RCVD_IN_MSPIKE_WL, SPF_HELO_PASS,URIBL_BLOCKED autolearn=ham autolearn_force=no version=3.4.6 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id 6C3FA27BBE2 for ; Tue, 23 Jan 2024 16:49:20 +0000 (GMT) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1rSJxL-0003uo-9G; Tue, 23 Jan 2024 11:48:59 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1rSJxJ-0003tu-MJ for guix-patches@gnu.org; Tue, 23 Jan 2024 11:48:57 -0500 Received: from debbugs.gnu.org ([2001:470:142:5::43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1rSJxJ-0004NQ-DU for guix-patches@gnu.org; Tue, 23 Jan 2024 11:48:57 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1rSJxO-00048j-3w for guix-patches@gnu.org; Tue, 23 Jan 2024 11:49:02 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#68677] [PATCH 1/6] services: secret-service: Make the endpoint configurable. Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Tue, 23 Jan 2024 16:49:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 68677 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 68677@debbugs.gnu.org Cc: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 68677-submit@debbugs.gnu.org id=B68677.170602853115817 (code B ref 68677); Tue, 23 Jan 2024 16:49:02 +0000 Received: (at 68677) by debbugs.gnu.org; 23 Jan 2024 16:48:51 +0000 Received: from localhost ([127.0.0.1]:43872 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1rSJxC-00046z-27 for submit@debbugs.gnu.org; Tue, 23 Jan 2024 11:48:50 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]:54786) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1rSJx9-000468-Hf for 68677@debbugs.gnu.org; Tue, 23 Jan 2024 11:48:48 -0500 Received: from fencepost.gnu.org ([2001:470:142:3::e]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1rSJwy-0004IU-UY; Tue, 23 Jan 2024 11:48:37 -0500 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=gnu.org; s=fencepost-gnu-org; h=MIME-Version:References:In-Reply-To:Date:Subject:To: From; bh=dgYi8/JjBUTr0ADRIHljhEgQOylTJpQYcKZo9APNDsQ=; b=UD7p5umH/hHxKWfKj5oW zcFwfNt+/FrE6y1stRsAZd8pU/UtztzEq4apkPwQecAVtzPQ+J3dr2KL2h9goy10CdvzC2QDeEH7w iEDFFA38d8wq8P/f8Owxx5TzeOnf+HsjYQ5bj+PRCsHkM4oD0Z+a5hV7KRHv+xL3ClhIRR78+jGze BiC2afYV/RI+ZhrKV+FpUubGVeLxZseArNRWU76uOMz64b9gVe+aJwJh/ksiGVtwhlF/l5PQ4UXbB 9o90xh5Xhr8hWF5RmR5AJOcHsVFAeil0aZVqVCoHmSUjeo8F1m8vL+dS12Rb2D3UH6+C42Pb/N+TJ uQoN//eifjfKPA==; From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Tue, 23 Jan 2024 17:48:16 +0100 Message-ID: <4eb616e06f6ecc291e3f144728c6010d051acdfb.1706027375.git.ludo@gnu.org> X-Mailer: git-send-email 2.41.0 In-Reply-To: References: MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org X-getmail-retrieved-from-mailbox: Patches Until now, the secret service had a hard-coded TCP endpoint on port 1004. This change lets users specify arbitrary socket addresses. * gnu/build/secret-service.scm (socket-address->string): New procedure, taken from Shepherd. (secret-service-send-secrets): Replace ‘port’ by ‘address’ and adjust accordingly. (secret-service-receive-secrets): Likewise. * gnu/services/virtualization.scm (secret-service-shepherd-services): Likewise. (secret-service-operating-system): Add optional ‘address’ parameter and honor it. Adjust ‘start’ method accordingly. Change-Id: I87a9514f1c170dca756ce76083d7182c6ebf6578 --- gnu/build/secret-service.scm | 62 +++++++++++++++++++++------------ gnu/services/virtualization.scm | 40 ++++++++++++--------- 2 files changed, 63 insertions(+), 39 deletions(-) diff --git a/gnu/build/secret-service.scm b/gnu/build/secret-service.scm index e13fd4eef3..0226c64032 100644 --- a/gnu/build/secret-service.scm +++ b/gnu/build/secret-service.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2020-2022 Ludovic Courtès +;;; Copyright © 2020-2023 Ludovic Courtès ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen ;;; ;;; This file is part of GNU Guix. @@ -93,13 +93,28 @@ (define (wait-for-readable-fd port timeout) ('readable #t) ('timeout #f))))))) -(define* (secret-service-send-secrets port secret-root +(define (socket-address->string address) + "Return a human-readable representation of ADDRESS, an object as returned by +'make-socket-address'." + (let ((family (sockaddr:fam address))) + (cond ((= AF_INET family) + (string-append (inet-ntop AF_INET (sockaddr:addr address)) + ":" (number->string (sockaddr:port address)))) + ((= AF_INET6 family) + (string-append "[" (inet-ntop AF_INET6 (sockaddr:addr address)) "]" + ":" (number->string (sockaddr:port address)))) + ((= AF_UNIX family) + (sockaddr:path address)) + (else + (object->string address))))) + +(define* (secret-service-send-secrets address secret-root #:key (retry 60) (handshake-timeout 180)) - "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." + "Copy all files under SECRET-ROOT by connecting to secret-service listening +at ADDRESS, an address as returned by 'make-socket-address'. If connection +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)))) @@ -118,9 +133,9 @@ (define* (secret-service-send-secrets port secret-root (dump-port input sock)))) files))) - (log "sending secrets to ~a~%" port) + (log "sending secrets to ~a~%" (socket-address->string address)) + (let ((sock (socket AF_INET (logior SOCK_CLOEXEC SOCK_STREAM) 0)) - (addr (make-socket-address AF_INET INADDR_LOOPBACK port)) (sleep (if (resolve-module '(fibers) #f) (module-ref (resolve-interface '(fibers)) 'sleep) sleep))) @@ -129,7 +144,7 @@ (define* (secret-service-send-secrets port secret-root ;; forward port inside the guest. (let loop ((retry retry)) (catch 'system-error - (cute connect sock addr) + (cute connect sock address) (lambda (key . args) (when (zero? retry) (apply throw key args)) @@ -147,7 +162,8 @@ (define* (secret-service-send-secrets port secret-root (('secret-service-server ('version version ...)) (log "sending files from ~s...~%" secret-root) (send-files sock) - (log "done sending files to port ~a~%" port) + (log "done sending files to ~a~%" + (socket-address->string address)) (close-port sock) secret-root) (x @@ -155,7 +171,8 @@ (define* (secret-service-send-secrets port secret-root (close-port sock) #f)) (begin ;timeout - (log "timeout while sending files to ~a~%" port) + (log "timeout while sending files to ~a~%" + (socket-address->string address)) (close-port sock) #f)))) @@ -168,19 +185,20 @@ (define (delete-file* file) (unless (= ENOENT (system-error-errno args)) (apply throw args))))) -(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. Return the list of files installed on success, -and #f otherwise." +(define (secret-service-receive-secrets address) + "Listen to ADDRESS, an address returned by 'make-socket-address', and wait +for a secret service client to send secrets. 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 - ;; virtio-serial ports, which would be safer, because they are - ;; (presumably) unsupported on GNU/Hurd. + (define (wait-for-client address) + ;; Wait for a connection on ADDRESS. Note: virtio-serial ports are safer + ;; than TCP connections but they are (presumably) unsupported on GNU/Hurd. (let ((sock (socket AF_INET (logior SOCK_CLOEXEC SOCK_STREAM) 0))) - (bind sock AF_INET INADDR_ANY port) + (bind sock address) (listen sock 1) - (log "waiting for secrets on port ~a...~%" port) + (log "waiting for secrets on ~a...~%" + (socket-address->string address)) + (match (select (list sock) '() '() 60) (((_) () ()) (match (accept sock) @@ -244,7 +262,7 @@ (define (secret-service-receive-secrets port) (log "invalid secrets received~%") #f))) - (let* ((port (wait-for-client port)) + (let* ((port (wait-for-client address)) (result (and=> port read-secrets))) (when port (close-port port)) diff --git a/gnu/services/virtualization.scm b/gnu/services/virtualization.scm index f0f0ab3bf1..5b8566f600 100644 --- a/gnu/services/virtualization.scm +++ b/gnu/services/virtualization.scm @@ -996,7 +996,7 @@ (define qemu-guest-agent-service-type ;;; Secrets for guest VMs. ;;; -(define (secret-service-shepherd-services port) +(define (secret-service-shepherd-services address) "Return a Shepherd service that fetches sensitive material at local PORT, over TCP. Reboot upon failure." ;; This is a Shepherd service, rather than an activation snippet, to make @@ -1018,7 +1018,7 @@ (define (secret-service-shepherd-services port) "receiving secrets from the host...~%") (force-output (current-error-port)) - (let ((sent (secret-service-receive-secrets #$port))) + (let ((sent (secret-service-receive-secrets #$address))) (unless sent (sleep 3) (reboot)))))) @@ -1039,9 +1039,13 @@ (define secret-service-type boot time. This service is meant to be used by virtual machines (VMs) that can only be accessed by their host."))) -(define (secret-service-operating-system os) +(define* (secret-service-operating-system os + #:optional + (address + #~(make-socket-address + AF_INET INADDR_ANY 1004))) "Return an operating system based on OS that includes the secret-service, -that will be listening to receive secret keys on port 1004, TCP." +that will be listening to receive secret keys on ADDRESS." (operating-system (inherit os) (services @@ -1049,7 +1053,7 @@ (define (secret-service-operating-system os) ;; activation: that requires entropy and thus takes time during boot, and ;; those keys are going to be overwritten by secrets received from the ;; host anyway. - (cons (service secret-service-type 1004) + (cons (service secret-service-type address) (modify-services (operating-system-user-services os) (openssh-service-type config => (openssh-configuration @@ -1243,24 +1247,26 @@ (define (hurd-vm-shepherd-service config) (source-module-closure '((gnu build secret-service) (guix build utils))) #~(lambda () - (let ((pid (fork+exec-command #$vm-command - #:user "childhurd" - ;; XXX TODO: use "childhurd" after - ;; updating Shepherd - #:group "kvm" - #:environment-variables - ;; QEMU tries to write to /var/tmp - ;; by default. - '("TMPDIR=/tmp"))) - (port #$(hurd-vm-port config %hurd-vm-secrets-port)) - (root #$(hurd-vm-configuration-secret-root config))) + (let* ((pid (fork+exec-command #$vm-command + #:user "childhurd" + ;; XXX TODO: use "childhurd" after + ;; updating Shepherd + #:group "kvm" + #:environment-variables + ;; QEMU tries to write to /var/tmp + ;; by default. + '("TMPDIR=/tmp"))) + (port #$(hurd-vm-port config %hurd-vm-secrets-port)) + (root #$(hurd-vm-configuration-secret-root config)) + (address (make-socket-address AF_INET INADDR_LOOPBACK + port))) (catch #t (lambda _ ;; 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) + (if (secret-service-send-secrets address root) pid (begin (kill (- pid) SIGTERM) From patchwork Tue Jan 23 16:48:17 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 59348 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id AB3A327BBEA; Tue, 23 Jan 2024 16:49:36 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-3.7 required=5.0 tests=BAYES_00,DKIM_INVALID, DKIM_SIGNED,MAILING_LIST_MULTI,RCVD_IN_MSPIKE_H5,RCVD_IN_MSPIKE_WL, SPF_HELO_PASS,URIBL_BLOCKED autolearn=ham autolearn_force=no version=3.4.6 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id 0295427BBE2 for ; Tue, 23 Jan 2024 16:49:36 +0000 (GMT) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1rSJxM-0003ve-Kz; Tue, 23 Jan 2024 11:49:00 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1rSJxK-0003u5-3c for guix-patches@gnu.org; Tue, 23 Jan 2024 11:48:58 -0500 Received: from debbugs.gnu.org ([2001:470:142:5::43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1rSJxJ-0004Nb-RU for guix-patches@gnu.org; Tue, 23 Jan 2024 11:48:57 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1rSJxO-00048q-Hp for guix-patches@gnu.org; Tue, 23 Jan 2024 11:49:02 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#68677] [PATCH 2/6] vm: Add =?utf-8?b?4oCYZGF0ZeKAmQ==?= field to . Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Tue, 23 Jan 2024 16:49:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 68677 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 68677@debbugs.gnu.org Cc: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 68677-submit@debbugs.gnu.org id=B68677.170602853615867 (code B ref 68677); Tue, 23 Jan 2024 16:49:02 +0000 Received: (at 68677) by debbugs.gnu.org; 23 Jan 2024 16:48:56 +0000 Received: from localhost ([127.0.0.1]:43882 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1rSJxH-00047k-U3 for submit@debbugs.gnu.org; Tue, 23 Jan 2024 11:48:56 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]:54796) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1rSJxA-00046C-0h for 68677@debbugs.gnu.org; Tue, 23 Jan 2024 11:48:49 -0500 Received: from fencepost.gnu.org ([2001:470:142:3::e]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1rSJwz-0004Iw-QU; Tue, 23 Jan 2024 11:48:37 -0500 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=gnu.org; s=fencepost-gnu-org; h=MIME-Version:References:In-Reply-To:Date:Subject:To: From; bh=cAvWI3+A24fwhNCoiakRvsRbMNqcG+UZ/OqnlO8UKPY=; b=WbTGopUEwmtik6H0Fs83 +iNvh9aOrt4CtAQBuEUDVeUqxDbAtkrBBrCFMujcj7Qc2RuwTQQz1iN8OrYjD99jsjiGe5T9/H/3u 8oF7apYNUC4W+nZArRW4AQzxwNMBiNYzQNZp0HNTi+sXd9fxlNJ7wzs+4IJCuSx01DYzeARUQk+LC qqR0qRuFiQM/TjG7H6ta9V+5EBJwprYxyT7sInL2/2HnPFhv+l9Trir539COVPQ2BLM/DWLvUDOtS YfBoylAEzKrz3uFST58KWr1rdNhAm4jocOUTA3Sh9q7fcKo3/JmlyfXKcEnhuv/lAgyIy6VUk1ReS bsGRpWVDQb8tOA==; From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Tue, 23 Jan 2024 17:48:17 +0100 Message-ID: <78e16db400df4d9bd53391120c756131ec62f2bd.1706027375.git.ludo@gnu.org> X-Mailer: git-send-email 2.41.0 In-Reply-To: References: MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org X-getmail-retrieved-from-mailbox: Patches * gnu/system/vm.scm ()[date]: New field. (virtual-machine-compiler): Honor it. Change-Id: Idab1c152466d57cbc6784c031a99fdfd37080bcb --- gnu/system/vm.scm | 34 +++++++++++++++++----------------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 8c27ff787d..33604d3229 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013-2022 Ludovic Courtès +;;; Copyright © 2013-2024 Ludovic Courtès ;;; Copyright © 2016 Christine Lemmer-Webber ;;; Copyright © 2016, 2017 Leo Famulari ;;; Copyright © 2017 Mathieu Othacehe @@ -63,6 +63,7 @@ (define-module (gnu system vm) #:use-module (gnu system uuid) #:use-module ((srfi srfi-1) #:hide (partition)) + #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (rnrs bytevectors) #:use-module (ice-9 match) @@ -326,7 +327,9 @@ (define-record-type* %virtual-machine (disk-image-size virtual-machine-disk-image-size ;integer (bytes) (default 'guess)) (port-forwardings virtual-machine-port-forwardings ;list of integer pairs - (default '()))) + (default '())) + (date virtual-machine-date ;SRFI-19 date | #f + (default #f))) (define-syntax virtual-machine (syntax-rules () @@ -353,22 +356,19 @@ (define-gexp-compiler (virtual-machine-compiler (vm ) system target) (match vm (($ os qemu volatile? graphic? memory-size - disk-image-size ()) - (system-qemu-image/shared-store-script os - #:system system - #:target target - #:qemu qemu - #:graphic? graphic? - #:volatile? volatile? - #:memory-size memory-size - #:disk-image-size - disk-image-size)) - (($ os qemu volatile? graphic? memory-size - disk-image-size forwardings) + disk-image-size forwardings date) (let ((options - `("-nic" ,(string-append - "user,model=virtio-net-pci," - (port-forwardings->qemu-options forwardings))))) + (append (if (null? forwardings) + '() + `("-nic" ,(string-append + "user,model=virtio-net-pci," + (port-forwardings->qemu-options + forwardings)))) + (if date + `("-rtc" + ,(string-append + "base=" (date->string date "~5"))) + '())))) (system-qemu-image/shared-store-script os #:system system #:target target From patchwork Tue Jan 23 16:48:18 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 59347 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 85DE927BBE9; Tue, 23 Jan 2024 16:49:34 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-3.7 required=5.0 tests=BAYES_00,DKIM_INVALID, DKIM_SIGNED,MAILING_LIST_MULTI,RCVD_IN_MSPIKE_H5,RCVD_IN_MSPIKE_WL, SPF_HELO_PASS,URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.6 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id E62C927BBE2 for ; Tue, 23 Jan 2024 16:49:32 +0000 (GMT) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1rSJxN-0003vx-0t; Tue, 23 Jan 2024 11:49:01 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1rSJxL-0003uY-1O for guix-patches@gnu.org; Tue, 23 Jan 2024 11:48:59 -0500 Received: from debbugs.gnu.org ([2001:470:142:5::43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1rSJxK-0004Nw-PL for guix-patches@gnu.org; Tue, 23 Jan 2024 11:48:58 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1rSJxO-00048y-U5 for guix-patches@gnu.org; Tue, 23 Jan 2024 11:49:03 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#68677] [PATCH 3/6] vm: Export accessors. Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Tue, 23 Jan 2024 16:49:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 68677 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 68677@debbugs.gnu.org Cc: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 68677-submit@debbugs.gnu.org id=B68677.170602853615874 (code B ref 68677); Tue, 23 Jan 2024 16:49:02 +0000 Received: (at 68677) by debbugs.gnu.org; 23 Jan 2024 16:48:56 +0000 Received: from localhost ([127.0.0.1]:43884 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1rSJxI-00047s-E1 for submit@debbugs.gnu.org; Tue, 23 Jan 2024 11:48:56 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]:39900) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1rSJxD-00046b-DT for 68677@debbugs.gnu.org; Tue, 23 Jan 2024 11:48:51 -0500 Received: from fencepost.gnu.org ([2001:470:142:3::e]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1rSJx1-0004Kx-Ni; Tue, 23 Jan 2024 11:48:41 -0500 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=gnu.org; s=fencepost-gnu-org; h=MIME-Version:References:In-Reply-To:Date:Subject:To: From; bh=tbdR1B8jPPx91mwRIa78VX8uA6l1Igx2vmW7BvBOaCY=; b=NTVnuXSd+RPpkZ2Rfk6x 0CDJmR2lRgxhcgU6rtZoibySD6+h2TnMlHJToNpl+MbOJchE4gudjEIDRI83BX0GAacbTEkGjZTll Y8p6PCVIt/usS8Kt5asIfqe/ZD3qn1CcKP3uMvRLQJMhjNKu1z5dqltOxemTeIAXMmtOLu/DsqSKP pgBUdx0dyib24wR9aFG3/AAph03OtI/NzllHSNLm0X6FgfDdrV3/Yl2KZQf6WEE05ZkPcVqaddiB3 wZpX31ib/ymGUJgyBdOkF72WkWTAYoiJOGZZlobAVgCf1KNNe8Ox7+QZcPRcx4wBSwRrW8jOIZBhu fcqYz6cf8eglLw==; From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Tue, 23 Jan 2024 17:48:18 +0100 Message-ID: <570cda7756f67c027e16b46cf5d5f80fdbf159f6.1706027375.git.ludo@gnu.org> X-Mailer: git-send-email 2.41.0 In-Reply-To: References: MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org X-getmail-retrieved-from-mailbox: Patches * gnu/system/vm.scm: Export. Change-Id: If65d96f4052d070af5baee26f3dd9b233b8480f4 --- gnu/system/vm.scm | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 33604d3229..a95f615e6b 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -72,7 +72,15 @@ (define-module (gnu system vm) system-qemu-image/shared-store-script virtual-machine - virtual-machine?)) + virtual-machine? + virtual-machine-operating-system + virtual-machine-qemu + virtual-machine-volatile? + virtual-machine-graphic? + virtual-machine-memory-size + virtual-machine-disk-image-size + virtual-machine-port-forwardings + virtual-machine-date)) ;;; Commentary: From patchwork Tue Jan 23 16:48:19 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 59349 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 212D827BBE9; Tue, 23 Jan 2024 16:49:41 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-3.7 required=5.0 tests=BAYES_00,DKIM_INVALID, DKIM_SIGNED,MAILING_LIST_MULTI,RCVD_IN_MSPIKE_H5,RCVD_IN_MSPIKE_WL, SPF_HELO_PASS,URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.6 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id 15A6D27BBE2 for ; Tue, 23 Jan 2024 16:49:39 +0000 (GMT) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1rSJxM-0003vg-Ks; Tue, 23 Jan 2024 11:49:00 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1rSJxL-0003uX-0T for guix-patches@gnu.org; Tue, 23 Jan 2024 11:48:59 -0500 Received: from debbugs.gnu.org ([2001:470:142:5::43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1rSJxK-0004Nz-OT for guix-patches@gnu.org; Tue, 23 Jan 2024 11:48:58 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1rSJxP-000496-F9 for guix-patches@gnu.org; Tue, 23 Jan 2024 11:49:03 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#68677] [PATCH 4/6] vm: Add =?utf-8?b?4oCYY3B1LWNvdW504oCZ?= field to . Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Tue, 23 Jan 2024 16:49:03 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 68677 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 68677@debbugs.gnu.org Cc: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 68677-submit@debbugs.gnu.org id=B68677.170602853715881 (code B ref 68677); Tue, 23 Jan 2024 16:49:03 +0000 Received: (at 68677) by debbugs.gnu.org; 23 Jan 2024 16:48:57 +0000 Received: from localhost ([127.0.0.1]:43886 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1rSJxI-00047z-N4 for submit@debbugs.gnu.org; Tue, 23 Jan 2024 11:48:56 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]:39894) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1rSJxD-00046a-DP for 68677@debbugs.gnu.org; Tue, 23 Jan 2024 11:48:51 -0500 Received: from fencepost.gnu.org ([2001:470:142:3::e]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1rSJx2-0004Le-JV; Tue, 23 Jan 2024 11:48:41 -0500 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=gnu.org; s=fencepost-gnu-org; h=MIME-Version:References:In-Reply-To:Date:Subject:To: From; bh=YYW9L6k4pr50iqQfBFgYB7wR6KR6IcUqwS0F8xifygA=; b=m1RMvjNaeDGvOC6XhMId CI1D1njt0wnQ5L0/P8mJxxyU8rxk5btNyT1m3R6FXdOokN2ow/EEIjZk1Ce63cafKtdEWHAUwy8YN jnqdi9zwgDjLRCZL2bnZ3E6vBBJoEnQndDXsuguLcwjUWvwhyHDFvwAiMcgPG3IyRjymmIW+ZwH1H Bdorr6Trgf0Ds28MY0Fjql6FPnW23CwUjURVc3rHJVeoTzHNjhLyUw5bBNQWNaKhIWzK01+9dOBTE tieMV1r0aigmfHWHOfy4ACEBQy7wBm3NgjAXGBluGKJ2h/vAcariX8ih/C2uSDJdS6lPhSijczmL5 AswpkYCybaPq3A==; From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Tue, 23 Jan 2024 17:48:19 +0100 Message-ID: X-Mailer: git-send-email 2.41.0 In-Reply-To: References: MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org X-getmail-retrieved-from-mailbox: Patches * gnu/system/vm.scm ()[cpu-count]: New field. (virtual-machine-compiler): Honor it. Change-Id: I907a89365f32ac7a9981c4ae5f59cf6eb199c3cc --- gnu/system/vm.scm | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index a95f615e6b..ef4c180058 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -75,6 +75,7 @@ (define-module (gnu system vm) virtual-machine? virtual-machine-operating-system virtual-machine-qemu + virtual-machine-cpu-count virtual-machine-volatile? virtual-machine-graphic? virtual-machine-memory-size @@ -326,6 +327,8 @@ (define-record-type* %virtual-machine (operating-system virtual-machine-operating-system) ; (qemu virtual-machine-qemu ; (default qemu-minimal)) + (cpu-count virtual-machine-cpu-count ;integer + (default 1)) (volatile? virtual-machine-volatile? ;Boolean (default #t)) (graphic? virtual-machine-graphic? ;Boolean @@ -363,7 +366,7 @@ (define (port-forwardings->qemu-options forwardings) (define-gexp-compiler (virtual-machine-compiler (vm ) system target) (match vm - (($ os qemu volatile? graphic? memory-size + (($ os qemu cpus volatile? graphic? memory-size disk-image-size forwardings date) (let ((options (append (if (null? forwardings) @@ -372,6 +375,10 @@ (define-gexp-compiler (virtual-machine-compiler (vm ) "user,model=virtio-net-pci," (port-forwardings->qemu-options forwardings)))) + (if (> cpus 1) + `("-smp" ,(string-append "cpus=" + (number->string cpus))) + '()) (if date `("-rtc" ,(string-append From patchwork Tue Jan 23 16:48:20 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 59345 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 90C0227BBE2; Tue, 23 Jan 2024 16:49:16 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-3.7 required=5.0 tests=BAYES_00,DKIM_INVALID, DKIM_SIGNED,MAILING_LIST_MULTI,RCVD_IN_MSPIKE_H5,RCVD_IN_MSPIKE_WL, SPF_HELO_PASS,URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.6 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id CDD9F27BBE9 for ; Tue, 23 Jan 2024 16:49:15 +0000 (GMT) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1rSJxN-0003wC-TN; Tue, 23 Jan 2024 11:49:01 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1rSJxL-0003ur-E9 for guix-patches@gnu.org; Tue, 23 Jan 2024 11:48:59 -0500 Received: from debbugs.gnu.org ([2001:470:142:5::43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1rSJxL-0004OO-5H for guix-patches@gnu.org; Tue, 23 Jan 2024 11:48:59 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1rSJxP-00049E-Ra for guix-patches@gnu.org; Tue, 23 Jan 2024 11:49:03 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#68677] [PATCH 5/6] marionette: Add #:peek? to =?utf-8?b?4oCY?= =?utf-8?b?d2FpdC1mb3ItdGNwLXBvcnQ/4oCZLg==?= Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Tue, 23 Jan 2024 16:49:03 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 68677 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 68677@debbugs.gnu.org Cc: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 68677-submit@debbugs.gnu.org id=B68677.170602853715888 (code B ref 68677); Tue, 23 Jan 2024 16:49:03 +0000 Received: (at 68677) by debbugs.gnu.org; 23 Jan 2024 16:48:57 +0000 Received: from localhost ([127.0.0.1]:43888 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1rSJxJ-000486-11 for submit@debbugs.gnu.org; Tue, 23 Jan 2024 11:48:57 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]:39910) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1rSJxD-00046c-Hy for 68677@debbugs.gnu.org; Tue, 23 Jan 2024 11:48:52 -0500 Received: from fencepost.gnu.org ([2001:470:142:3::e]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1rSJx3-0004Ll-H6; Tue, 23 Jan 2024 11:48:41 -0500 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=gnu.org; s=fencepost-gnu-org; h=MIME-Version:References:In-Reply-To:Date:Subject:To: From; bh=cGLxYu+dVr5jOkZbNRHT6+oiFJRAtqVY5y0OdXmWqBw=; b=i/TzJXbCsMWl2zNBAI9m XeesP6cOOUDBpr7mTmoPTONk1fAD9qQRtCLB2Ly/ZHQ24HpaWJUgkAnwGMrhStnO1b+32xYGP9+hi /snztD4NiN2iDilyTWMuf1duGx90JlIuxJegNAgmkotthyiTlUEj/XQD6JmaStGxyfhzGt5UdNCA6 Z8BxcqDr5q8ESrGWRp5lPIza86k3eH8YPJeBZ6rOx8VorBY+a7bRl9+214jri+iCM5zyZff54hpJH XgO4bd6b7TRXFsnGfQjxXuBejwPNd5zaQ+kfQzujCg7/5ObSzz2GJXCM/Px/frjupzrupZ7IR9Buh AWgxhigzDqzNXg==; From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Tue, 23 Jan 2024 17:48:20 +0100 Message-ID: <85175dd568a9283816652a6124f14cd65505bb22.1706027375.git.ludo@gnu.org> X-Mailer: git-send-email 2.41.0 In-Reply-To: References: MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org X-getmail-retrieved-from-mailbox: Patches * gnu/build/marionette.scm (wait-for-tcp-port): Add #:peek? parameter and honor it. Change-Id: Ie7515a5223299390ab8af6fe5aa3cf63ba5c8078 --- gnu/build/marionette.scm | 32 ++++++++++++++++++++++++++------ 1 file changed, 26 insertions(+), 6 deletions(-) diff --git a/gnu/build/marionette.scm b/gnu/build/marionette.scm index 27c10e3dfe..0b0a8a70d8 100644 --- a/gnu/build/marionette.scm +++ b/gnu/build/marionette.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016-2022 Ludovic Courtès +;;; Copyright © 2016-2022, 2024 Ludovic Courtès ;;; Copyright © 2018 Chris Marusich ;;; Copyright © 2022, 2023 Maxim Cournoyer ;;; Copyright © 2023 Bruno Victal @@ -223,29 +223,49 @@ (define* (wait-for-file file marionette (define* (wait-for-tcp-port port marionette #:key (timeout 20) + (peek? #f) (address `(make-socket-address AF_INET INADDR_LOOPBACK ,port))) "Wait for up to TIMEOUT seconds for PORT to accept connections in MARIONETTE. ADDRESS must be an expression that returns a socket address, -typically a call to 'make-socket-address'. Raise an error on failure." +typically a call to 'make-socket-address'. When PEEK? is true, attempt to +read a byte from the socket upon connection; retry if that gives the +end-of-file object. + +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 - `(let* ((address ,address) - (sock (socket (sockaddr:fam address) SOCK_STREAM 0))) - (let loop ((i 0)) + `(let* ((address ,address)) + (define (open-socket) + (socket (sockaddr:fam address) SOCK_STREAM 0)) + + (let loop ((sock (open-socket)) + (i 0)) (catch 'system-error (lambda () (connect sock address) + (when ,peek? + (let ((byte ((@ (ice-9 binary-ports) lookahead-u8) + sock))) + (when (eof-object? byte) + (close-port sock) + (throw 'system-error + "wait-for-tcp-port" "~A" + (list (strerror ECONNRESET)) + (list ECONNRESET))))) (close-port sock) 'success) (lambda args (if (< i ,timeout) (begin (sleep 1) - (loop (+ 1 i))) + (loop (if (port-closed? sock) + (open-socket) + sock) + (+ 1 i))) (list 'failure address)))))) marionette) ('success #t) From patchwork Tue Jan 23 16:48:21 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 59350 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 476A427BBE9; Tue, 23 Jan 2024 16:50:21 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-3.7 required=5.0 tests=BAYES_00,DKIM_INVALID, DKIM_SIGNED,MAILING_LIST_MULTI,RCVD_IN_MSPIKE_H5,RCVD_IN_MSPIKE_WL, SPF_HELO_PASS,URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.6 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id A9E5B27BBE2 for ; Tue, 23 Jan 2024 16:50:15 +0000 (GMT) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1rSJyL-0004FI-MF; Tue, 23 Jan 2024 11:50:01 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1rSJyI-0004F0-0U for guix-patches@gnu.org; Tue, 23 Jan 2024 11:49:58 -0500 Received: from debbugs.gnu.org ([2001:470:142:5::43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1rSJyH-0004Zv-Oi for guix-patches@gnu.org; Tue, 23 Jan 2024 11:49:57 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1rSJyM-0004CJ-Ei for guix-patches@gnu.org; Tue, 23 Jan 2024 11:50:02 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#68677] [PATCH 6/6] services: Add =?utf-8?b?4oCYdmlydHVhbC1i?= =?utf-8?b?dWlsZC1tYWNoaW5l4oCZ?= service. Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Tue, 23 Jan 2024 16:50:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 68677 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 68677@debbugs.gnu.org Cc: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 68677-submit@debbugs.gnu.org id=B68677.170602855215990 (code B ref 68677); Tue, 23 Jan 2024 16:50:02 +0000 Received: (at 68677) by debbugs.gnu.org; 23 Jan 2024 16:49:12 +0000 Received: from localhost ([127.0.0.1]:43895 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1rSJxW-00049l-FA for submit@debbugs.gnu.org; Tue, 23 Jan 2024 11:49:12 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]:39924) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1rSJxF-00046r-EU for 68677@debbugs.gnu.org; Tue, 23 Jan 2024 11:48:55 -0500 Received: from fencepost.gnu.org ([2001:470:142:3::e]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1rSJx4-0004M5-Kv; Tue, 23 Jan 2024 11:48:43 -0500 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=gnu.org; s=fencepost-gnu-org; h=MIME-Version:References:In-Reply-To:Date:Subject:To: From; bh=Tp3/U65F9VB3bDmGJi9a7MNBxCDI5zF9QPgrbhYmLr0=; b=a/a+3Myh6TYvyFifTvCI saMCMC8xVEq1j+I6KlbeJp5nCOhWGwrDQCKaYXPVBCMambg6oNA81aKo2p1FpuqtBxcq4mC+5cRjh vbCY7I/0Lhs8FgffllLxI0HcHnVU109Z1/z5d+0RbD4ARmIve8xfphsJ4yQMn5sr35/p6KN7nw5pj vK39JtVHT8T6zQE3usHvGxoMwv/tV76ok8uV1SXi4ewKw5lHNVjHFz+9oU7/MxHaMguGYr39WqWbW bNZwK2BCIb43M7Qu81IJPLQ5O/9WXTEaGRPBlEvsh3fOWY9JUNEAnIpB167/nDY2SPgcJ6J/vb2Ml Ou6EyXshzogzew==; From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Tue, 23 Jan 2024 17:48:21 +0100 Message-ID: X-Mailer: git-send-email 2.41.0 In-Reply-To: References: MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org X-getmail-retrieved-from-mailbox: Patches * gnu/services/virtualization.scm (): New record type. (%build-vm-ssh-port, %build-vm-secrets-port, %x86-64-intel-cpu-models): New variables. (qemu-cpu-model-for-date, virtual-build-machine-ssh-port) (virtual-build-machine-secrets-port): New procedures. (%minimal-vm-syslog-config, %virtual-build-machine-operating-system): New variables. (virtual-build-machine-default-image): (virtual-build-machine-account-name) (virtual-build-machine-accounts) (build-vm-shepherd-services) (initialize-build-vm-substitutes) (build-vm-activation) (virtual-build-machine-offloading-ssh-key) (virtual-build-machine-activation) (virtual-build-machine-secret-root) (check-vm-availability) (build-vm-guix-extension): New procedures. (initialize-hurd-vm-substitutes): Remove. (hurd-vm-activation): Rewrite in terms of ‘build-vm-activation’. * gnu/system/vm.scm (linux-image-startup-command): New procedure. (operating-system-for-image): Export. * gnu/tests/virtualization.scm (run-command-over-ssh): New procedure, extracted from… (run-childhurd-test): … here. [test]: Adjust accordingly. (%build-vm-os): New variable. (run-build-vm-test): New procedure. (%test-build-vm): New variable. * doc/guix.texi (Virtualization Services)[Virtual Build Machines]: New section. (Build Environment Setup): Add cross-reference. Change-Id: I0a47652a583062314020325aedb654f11cb2499c --- doc/guix.texi | 139 +++++++- gnu/services/virtualization.scm | 600 +++++++++++++++++++++++++------- gnu/system/image.scm | 1 + gnu/system/vm.scm | 62 +++- gnu/tests/virtualization.scm | 176 ++++++++-- 5 files changed, 810 insertions(+), 168 deletions(-) diff --git a/doc/guix.texi b/doc/guix.texi index ac17f91f7d..04a6bf2bcd 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -22,7 +22,7 @@ @set SUBSTITUTE-URLS https://@value{SUBSTITUTE-SERVER-1} https://@value{SUBSTITUTE-SERVER-2} @copying -Copyright @copyright{} 2012-2023 Ludovic Courtès@* +Copyright @copyright{} 2012-2024 Ludovic Courtès@* Copyright @copyright{} 2013, 2014, 2016 Andreas Enge@* Copyright @copyright{} 2013 Nikita Karetnikov@* Copyright @copyright{} 2014, 2015, 2016 Alex Kost@* @@ -1297,6 +1297,11 @@ Build Environment Setup @file{/homeless-shelter}. This helps to highlight inappropriate uses of @env{HOME} in the build scripts of packages. +All this usually enough to ensure details of the environment do not +influence build processes. In some exceptional cases where more control +is needed---typically over the date, kernel, or CPU---you can resort to +a virtual build machine (@pxref{build-vm, virtual build machines}). + You can influence the directory where the daemon stores build trees @i{via} the @env{TMPDIR} environment variable. However, the build tree within the chroot is always called @file{/tmp/guix-build-@var{name}.drv-0}, @@ -36081,6 +36086,138 @@ Virtualization Services @end deftp +@anchor{build-vm} +@subsubheading Virtual Build Machines + +@cindex virtual build machines +@cindex build VMs +@cindex VMs, for offloading +@dfn{Virtual build machines} or ``build VMs'' let you offload builds to +a fully controlled environment. ``How can it be more controlled than +regular builds? And why would it be useful?'', you ask. Good +questions. + +Builds spawned by @code{guix-daemon} indeed run in a controlled +environment; specifically the daemon spawns build processes in separate +namespaces and in a chroot, such as that build processes only see their +declared dependencies and a well-defined subset of the file system tree +(@pxref{Build Environment Setup}, for details). A few aspects of the +environments are not controlled though: the operating system kernel, the +CPU model, and the date. Most of the time, these aspects have no impact +on the build process: the level of isolation @code{guix-daemon} provides +is ``good enough''. + +@cindex time traps +However, there are occasionally cases where those aspects @emph{do} +influence the build process. A typical example is @dfn{time traps}: +build processes that stop working after a certain date@footnote{The most +widespread example of time traps is test suites that involve checking +the expiration date of a certificate. Such tests exists in TLS +implementations such as OpenSSL and GnuTLS, but also in high-level +software such as Python.}. Another one is software that optimizes for +the CPU microarchitecture it is built on or, worse, bugs that manifest +only on specific CPUs. + +To address that, @code{virtual-build-machine-service-type} lets you add +a virtual build machine on your system, as in this example: + +@lisp +(use-modules (gnu services virtualization)) + +(operating-system + ;; @dots{} + (services (append (list (service virtual-build-machine-service-type)) + %base-services))) +@end lisp + +By default, you have to explicitly start the build machine when you need +it, at which point builds may be offloaded to it (@pxref{Daemon Offload +Setup}): + +@example +herd start build-vm +@end example + +With the default setting shown above, the build VM runs with its clock +set to a date several years in the past, and on a CPU model that +corresponds to that date---a model possibly older than that of your +machine. This lets you rebuild today software from the past that would +otherwise fail to build due to a time trap or other issues in its build +process. + +You can configure the build VM, as in this example: + +@lisp +(service virtual-build-machine-service-type + (virtual-build-machine + (cpu "Westmere") + (cpu-count 8) + (memory-size (* 1 1024)) + (auto-start? #t))) +@end lisp + +The available options are shown below. + +@defvar virtual-build-machine-service-type +This is the service type to run @dfn{virtual build machines}. Virtual +build machines are configured so that builds are offloaded to them when +they are running. +@end defvar + +@deftp {Data Type} virtual-build-machine +This is the data type specifying the configuration of a build machine. +It contains the fields below: + +@table @asis +@item @code{name} (default: @code{'build-vm}) +The name of this build VM. It is used to construct the name of its +Shepherd service. + +@item @code{image} +The image of the virtual machine (@pxref{System Images}). This notably +specifies the virtual disk size and the operating system running into it +(@pxref{operating-system Reference}). The default value is a minimal +operating system image. + +@item @code{qemu} (default: @code{qemu-minimal}) +The QEMU package to run the image. + +@item @code{cpu} +The CPU model being emulated as a string denoting a model known to QEMU. + +The default value is a model that matches @code{date} (see below). To +see what CPU models are available, run, for example: + +@example +qemu-system-x86_64 -cpu help +@end example + +@item @code{cpu-count} (default: @code{4}) +The number of CPUs emulated by the virtual machine. + +@item @code{memory-size} (default: @code{2048}) +Size in mebibytes (MiB) of the virtual machine's main memory (RAM). + +@item @code{date} (default: a few years ago) +Date inside the virtual machine when it starts; this must be a SRFI-19 +date object (@pxref{SRFI-19 Date,,, guile, GNU Guile Reference Manual}). + +@item @code{port-forwardings} (default: 11022 and 11004) +TCP ports of the virtual machine forwarded to the host. By default, the +SSH and secrets ports are forwarded into the host. + +@item @code{systems} (default: @code{(list (%current-system))}) +List of system types supported by the build VM---e.g., +@code{"x86_64-linux"}. + +@item @code{auto-start?} (default: @code{#f}) +Whether to start the virtual machine when the system boots. +@end table +@end deftp + +In the next section, you'll find a variant on this theme: GNU/Hurd +virtual machines! + @anchor{hurd-vm} @subsubheading The Hurd in a Virtual Machine diff --git a/gnu/services/virtualization.scm b/gnu/services/virtualization.scm index 5b8566f600..907d641c6a 100644 --- a/gnu/services/virtualization.scm +++ b/gnu/services/virtualization.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Ryan Moe -;;; Copyright © 2018, 2020-2023 Ludovic Courtès +;;; Copyright © 2018, 2020-2024 Ludovic Courtès ;;; Copyright © 2020, 2021, 2023 Janneke Nieuwenhuizen ;;; Copyright © 2021 Timotej Lazar ;;; Copyright © 2022 Oleg Pykhalov @@ -43,6 +43,8 @@ (define-module (gnu services virtualization) #:use-module (gnu system hurd) #:use-module (gnu system image) #:use-module (gnu system shadow) + #:autoload (gnu system vm) (linux-image-startup-command + virtualized-operating-system) #:use-module (gnu system) #:use-module (guix derivations) #:use-module (guix gexp) @@ -55,12 +57,20 @@ (define-module (gnu services virtualization) #:autoload (guix self) (make-config.scm) #:autoload (guix platform) (platform-system) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) + #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (rnrs bytevectors) #:use-module (ice-9 match) - #:export (%hurd-vm-operating-system + #:export (virtual-build-machine + virtual-build-machine-service-type + + %virtual-build-machine-operating-system + %virtual-build-machine-default-vm + + %hurd-vm-operating-system hurd-vm-configuration hurd-vm-configuration? hurd-vm-configuration-os @@ -1064,6 +1074,459 @@ (define* (secret-service-operating-system os (inherit config) (generate-substitute-key? #f)))))))) + +;;; +;;; Offloading-as-a-service. +;;; + +(define-record-type* + virtual-build-machine make-virtual-build-machine + virtual-build-machine? + this-virtual-build-machine + (name virtual-build-machine-name + (default 'build-vm)) + (image virtual-build-machine-image + (thunked) + (default + (virtual-build-machine-default-image + this-virtual-build-machine))) + (qemu virtual-build-machine-qemu + (default qemu-minimal)) + (cpu virtual-build-machine-cpu + (thunked) + (default + (qemu-cpu-model-for-date + (virtual-build-machine-systems this-virtual-build-machine) + (virtual-build-machine-date this-virtual-build-machine)))) + (cpu-count virtual-build-machine-cpu-count + (default 4)) + (memory-size virtual-build-machine-memory-size ;integer (MiB) + (default 2048)) + (date virtual-build-machine-date + (default (make-date 0 0 00 00 01 01 2020 0))) + (port-forwardings virtual-build-machine-port-forwardings + (default + `((,%build-vm-ssh-port . 22) + (,%build-vm-secrets-port . 1004)))) + (systems virtual-build-machine-systems + (default (list (%current-system)))) + (auto-start? virtual-build-machine-auto-start? + (default #f))) + +(define %build-vm-ssh-port + ;; Default host port where the guest's SSH port is forwarded. + 11022) + +(define %build-vm-secrets-port + ;; Host port to communicate secrets to the build VM. + ;; FIXME: Anyone on the host can talk to it; use virtio ports or AF_VSOCK + ;; instead. + 11044) + +(define %x86-64-intel-cpu-models + ;; List of release date/CPU model pairs representing Intel's x86_64 models. + ;; The list is taken from + ;; . + ;; CPU model strings are those found in 'qemu-system-x86_64 -cpu help'. + (letrec-syntax ((cpu-models (syntax-rules () + ((_ (date model) rest ...) + (alist-cons (date->time-utc + (string->date date "~Y-~m-~d")) + model + (cpu-models rest ...))) + ((_) + '())))) + (reverse + (cpu-models ("2006-01-01" "core2duo") + ("2010-01-01" "Westmere") + ("2008-01-01" "Nehalem") + ("2011-01-01" "SandyBridge") + ("2012-01-01" "IvyBridge") + ("2013-01-01" "Haswell") + ("2014-01-01" "Broadwell") + ("2015-01-01" "Skylake-Client"))))) + +(define (qemu-cpu-model-for-date systems date) + "Return the QEMU name of a CPU model for SYSTEMS that was current at DATE." + (if (any (cut string-prefix? "x86_64-" <>) systems) + (let ((time (date->time-utc date))) + (any (match-lambda + ((release-date . model) + (and (time + (guix-configuration + (inherit config) + (authorize-key? #f))) + (syslog-service-type config => + (syslog-configuration + (config-file + %minimal-vm-syslog-config))) + (delete mingetty-service-type) + (delete console-font-service-type)))))) + +(define (virtual-build-machine-default-image config) + (let* ((type (lookup-image-type-by-name 'mbr-raw)) + (base (os->image %virtual-build-machine-operating-system + #:type type))) + (image (inherit base) + (name (symbol-append 'build-vm- + (virtual-build-machine-name config))) + (format 'compressed-qcow2) + (partition-table-type 'mbr) + (shared-store? #f) + (size (* 10 (expt 2 30)))))) + +(define (virtual-build-machine-account-name config) + (string-append "build-vm-" + (symbol->string + (virtual-build-machine-name config)))) + +(define (virtual-build-machine-accounts config) + (let ((name (virtual-build-machine-account-name config))) + (list (user-group (name name) (system? #t)) + (user-account + (name name) + (group name) + (supplementary-groups '("kvm")) + (comment "Privilege separation user for the virtual build machine") + (home-directory "/var/empty") + (shell (file-append shadow "/sbin/nologin")) + (system? #t))))) + +(define (build-vm-shepherd-services config) + (define transform + (compose secret-service-operating-system + operating-system-with-locked-root-account + operating-system-with-offloading-account + (lambda (os) + (virtualized-operating-system os #:full-boot? #t)))) + + (define transformed-image + (let ((base (virtual-build-machine-image config))) + (image + (inherit base) + (operating-system + (transform (image-operating-system base)))))) + + (define command + (linux-image-startup-command transformed-image + #:qemu + (virtual-build-machine-qemu config) + #:cpu + (virtual-build-machine-cpu config) + #:cpu-count + (virtual-build-machine-cpu-count config) + #:memory-size + (virtual-build-machine-memory-size config) + #:port-forwardings + (virtual-build-machine-port-forwardings + config) + #:date + (virtual-build-machine-date config))) + + (define user + (virtual-build-machine-account-name config)) + + (list (shepherd-service + (documentation "Run the build virtual machine service.") + (provision (list (virtual-build-machine-name config))) + (requirement '(user-processes)) + (modules `((gnu build secret-service) + (guix build utils) + ,@%default-modules)) + (start + (with-imported-modules (source-module-closure + '((gnu build secret-service) + (guix build utils))) + #~(lambda arguments + (let* ((pid (fork+exec-command (append #$command arguments) + #:user #$user + #:group "kvm" + #:environment-variables + ;; QEMU tries to write to /var/tmp + ;; by default. + '("TMPDIR=/tmp"))) + (port #$(virtual-build-machine-secrets-port config)) + (root #$(virtual-build-machine-secret-root config)) + (address (make-socket-address AF_INET INADDR_LOOPBACK + port))) + (catch #t + (lambda _ + (if (secret-service-send-secrets address root) + pid + (begin + (kill (- pid) SIGTERM) + #f))) + (lambda (key . args) + (kill (- pid) SIGTERM) + (apply throw key args))))))) + (stop #~(make-kill-destructor)) + (auto-start? (virtual-build-machine-auto-start? config))))) + +(define (authorize-guest-substitutes-on-host) + "Return a program that authorizes the guest's archive signing key (passed as +an argument) on the host." + (define not-config? + (match-lambda + ('(guix config) #f) + (('guix _ ...) #t) + (('gnu _ ...) #t) + (_ #f))) + + (define run + (with-extensions (list guile-gcrypt) + (with-imported-modules `(((guix config) => ,(make-config.scm)) + ,@(source-module-closure + '((guix pki) + (guix build utils)) + #:select? not-config?)) + #~(begin + (use-modules (ice-9 match) + (ice-9 textual-ports) + (gcrypt pk-crypto) + (guix pki) + (guix build utils)) + + (match (command-line) + ((_ guest-config-directory) + (let ((guest-key (string-append guest-config-directory + "/signing-key.pub"))) + (if (file-exists? guest-key) + ;; Add guest key to the host's ACL. + (let* ((key (string->canonical-sexp + (call-with-input-file guest-key + get-string-all))) + (acl (public-keys->acl + (cons key (acl->public-keys (current-acl)))))) + (with-atomic-file-replacement %acl-file + (lambda (_ port) + (write-acl acl port)))) + (format (current-error-port) + "warning: guest key missing from '~a'~%" + guest-key))))))))) + + (program-file "authorize-guest-substitutes-on-host" run)) + +(define (initialize-build-vm-substitutes) + "Initialize the Hurd VM's key pair and ACL and store it on the host." + (define run + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (ice-9 match)) + + (define host-key + "/etc/guix/signing-key.pub") + + (define host-acl + "/etc/guix/acl") + + (match (command-line) + ((_ guest-config-directory) + (setenv "GUIX_CONFIGURATION_DIRECTORY" + guest-config-directory) + (invoke #+(file-append guix "/bin/guix") "archive" + "--generate-key") + + (when (file-exists? host-acl) + ;; Copy the host ACL. + (copy-file host-acl + (string-append guest-config-directory + "/acl"))) + + (when (file-exists? host-key) + ;; Add the host key to the childhurd's ACL. + (let ((key (open-fdes host-key O_RDONLY))) + (close-fdes 0) + (dup2 key 0) + (execl #+(file-append guix "/bin/guix") + "guix" "archive" "--authorize")))))))) + + (program-file "initialize-build-vm-substitutes" run)) + +(define* (build-vm-activation secret-directory + #:key + offloading-ssh-key + (offloading? #t)) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + + (define secret-directory + #$secret-directory) + + (define ssh-directory + (string-append secret-directory "/etc/ssh")) + + (define guix-directory + (string-append secret-directory "/etc/guix")) + + (define offloading-ssh-key + #$offloading-ssh-key) + + (unless (file-exists? ssh-directory) + ;; Generate SSH host keys under SSH-DIRECTORY. + (mkdir-p ssh-directory) + (invoke #$(file-append openssh "/bin/ssh-keygen") + "-A" "-f" secret-directory)) + + (unless (or (not #$offloading?) + (file-exists? offloading-ssh-key)) + ;; Generate a user SSH key pair for the host to use when offloading + ;; to the guest. + (mkdir-p (dirname offloading-ssh-key)) + (invoke #$(file-append openssh "/bin/ssh-keygen") + "-t" "ed25519" "-N" "" + "-f" offloading-ssh-key) + + ;; Authorize it in the guest for user 'offloading'. + (let ((authorizations + (string-append ssh-directory + "/authorized_keys.d/offloading"))) + (mkdir-p (dirname authorizations)) + (copy-file (string-append offloading-ssh-key ".pub") + authorizations) + (chmod (dirname authorizations) #o555))) + + (unless (file-exists? guix-directory) + (invoke #$(initialize-build-vm-substitutes) + guix-directory)) + + (when #$offloading? + ;; Authorize the archive signing key from GUIX-DIRECTORY in the host. + (invoke #$(authorize-guest-substitutes-on-host) guix-directory))))) + +(define (virtual-build-machine-offloading-ssh-key config) + "Return the name of the file containing the SSH key of user 'offloading'." + (string-append "/etc/guix/offload/ssh/virtual-build-machine/" + (symbol->string + (virtual-build-machine-name config)))) + +(define (virtual-build-machine-activation config) + "Return a gexp to activate the build VM according to CONFIG." + (build-vm-activation (virtual-build-machine-secret-root config) + #:offloading? #t + #:offloading-ssh-key + (virtual-build-machine-offloading-ssh-key config))) + +(define (virtual-build-machine-secret-root config) + (string-append "/etc/guix/virtual-build-machines/" + (symbol->string + (virtual-build-machine-name config)))) + +(define (check-vm-availability config) + "Return a Scheme file that evaluates to true if the service corresponding to +CONFIG, a , is up and running." + (define service-name + (virtual-build-machine-name config)) + + (scheme-file "check-build-vm-availability.scm" + #~(begin + (use-modules (gnu services herd) + (srfi srfi-34)) + + (guard (c ((service-not-found-error? c) #f)) + (->bool (current-service '#$service-name)))))) + +(define (build-vm-guix-extension config) + (define vm-ssh-key + (string-append + (virtual-build-machine-secret-root config) + "/etc/ssh/ssh_host_ed25519_key.pub")) + + (define host-ssh-key + (virtual-build-machine-offloading-ssh-key config)) + + (guix-extension + (build-machines + (list #~(if (primitive-load #$(check-vm-availability config)) + (list (build-machine + (name "localhost") + (port #$(virtual-build-machine-ssh-port config)) + (systems + '#$(virtual-build-machine-systems config)) + (user "offloading") + (host-key (call-with-input-file #$vm-ssh-key + (@ (ice-9 textual-ports) + get-string-all))) + (private-key #$host-ssh-key))) + '()))))) + +(define virtual-build-machine-service-type + (service-type + (name 'build-vm) + (extensions (list (service-extension shepherd-root-service-type + build-vm-shepherd-services) + (service-extension guix-service-type + build-vm-guix-extension) + (service-extension account-service-type + virtual-build-machine-accounts) + (service-extension activation-service-type + virtual-build-machine-activation))) + (description + "Create a @dfn{virtual build machine}: a virtual machine (VM) that builds +can be offloaded to. By default, the virtual machine starts with a clock +running at some point in the past.") + (default-value (virtual-build-machine)))) + ;;; ;;; The Hurd in VM service: a Childhurd. @@ -1290,136 +1753,13 @@ (define %hurd-vm-accounts (shell (file-append shadow "/sbin/nologin")) (system? #t)))) -(define (initialize-hurd-vm-substitutes) - "Initialize the Hurd VM's key pair and ACL and store it on the host." - (define run - (with-imported-modules '((guix build utils)) - #~(begin - (use-modules (guix build utils) - (ice-9 match)) - - (define host-key - "/etc/guix/signing-key.pub") - - (define host-acl - "/etc/guix/acl") - - (match (command-line) - ((_ guest-config-directory) - (setenv "GUIX_CONFIGURATION_DIRECTORY" - guest-config-directory) - (invoke #+(file-append guix "/bin/guix") "archive" - "--generate-key") - - (when (file-exists? host-acl) - ;; Copy the host ACL. - (copy-file host-acl - (string-append guest-config-directory - "/acl"))) - - (when (file-exists? host-key) - ;; Add the host key to the childhurd's ACL. - (let ((key (open-fdes host-key O_RDONLY))) - (close-fdes 0) - (dup2 key 0) - (execl #+(file-append guix "/bin/guix") - "guix" "archive" "--authorize")))))))) - - (program-file "initialize-hurd-vm-substitutes" run)) - -(define (authorize-guest-substitutes-on-host) - "Return a program that authorizes the guest's archive signing key (passed as -an argument) on the host." - (define not-config? - (match-lambda - ('(guix config) #f) - (('guix _ ...) #t) - (('gnu _ ...) #t) - (_ #f))) - - (define run - (with-extensions (list guile-gcrypt) - (with-imported-modules `(((guix config) => ,(make-config.scm)) - ,@(source-module-closure - '((guix pki) - (guix build utils)) - #:select? not-config?)) - #~(begin - (use-modules (ice-9 match) - (ice-9 textual-ports) - (gcrypt pk-crypto) - (guix pki) - (guix build utils)) - - (match (command-line) - ((_ guest-config-directory) - (let ((guest-key (string-append guest-config-directory - "/signing-key.pub"))) - (if (file-exists? guest-key) - ;; Add guest key to the host's ACL. - (let* ((key (string->canonical-sexp - (call-with-input-file guest-key - get-string-all))) - (acl (public-keys->acl - (cons key (acl->public-keys (current-acl)))))) - (with-atomic-file-replacement %acl-file - (lambda (_ port) - (write-acl acl port)))) - (format (current-error-port) - "warning: guest key missing from '~a'~%" - guest-key))))))))) - - (program-file "authorize-guest-substitutes-on-host" run)) - (define (hurd-vm-activation config) "Return a gexp to activate the Hurd VM according to CONFIG." - (with-imported-modules '((guix build utils)) - #~(begin - (use-modules (guix build utils)) - - (define secret-directory - #$(hurd-vm-configuration-secret-root config)) - - (define ssh-directory - (string-append secret-directory "/etc/ssh")) - - (define guix-directory - (string-append secret-directory "/etc/guix")) - - (define offloading-ssh-key - #$(hurd-vm-configuration-offloading-ssh-key config)) - - (unless (file-exists? ssh-directory) - ;; Generate SSH host keys under SSH-DIRECTORY. - (mkdir-p ssh-directory) - (invoke #$(file-append openssh "/bin/ssh-keygen") - "-A" "-f" secret-directory)) - - (unless (or (not #$(hurd-vm-configuration-offloading? config)) - (file-exists? offloading-ssh-key)) - ;; Generate a user SSH key pair for the host to use when offloading - ;; to the guest. - (mkdir-p (dirname offloading-ssh-key)) - (invoke #$(file-append openssh "/bin/ssh-keygen") - "-t" "ed25519" "-N" "" - "-f" offloading-ssh-key) - - ;; Authorize it in the guest for user 'offloading'. - (let ((authorizations - (string-append ssh-directory - "/authorized_keys.d/offloading"))) - (mkdir-p (dirname authorizations)) - (copy-file (string-append offloading-ssh-key ".pub") - authorizations) - (chmod (dirname authorizations) #o555))) - - (unless (file-exists? guix-directory) - (invoke #$(initialize-hurd-vm-substitutes) - guix-directory)) - - (when #$(hurd-vm-configuration-offloading? config) - ;; Authorize the archive signing key from GUIX-DIRECTORY in the host. - (invoke #$(authorize-guest-substitutes-on-host) guix-directory))))) + (build-vm-activation (hurd-vm-configuration-secret-root config) + #:offloading? + (hurd-vm-configuration-offloading? config) + #:offloading-ssh-key + (hurd-vm-configuration-offloading-ssh-key config))) (define (hurd-vm-configuration-offloading-ssh-key config) "Return the name of the file containing the SSH key of user 'offloading'." diff --git a/gnu/system/image.scm b/gnu/system/image.scm index 2cc1012893..87df2fa088 100644 --- a/gnu/system/image.scm +++ b/gnu/system/image.scm @@ -72,6 +72,7 @@ (define-module (gnu system image) #:export (root-offset root-label image-without-os + operating-system-for-image esp-partition esp32-partition diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index ef4c180058..fcfd1cdb48 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -71,6 +71,8 @@ (define-module (gnu system vm) #:export (virtualized-operating-system system-qemu-image/shared-store-script + linux-image-startup-command + virtual-machine virtual-machine? virtual-machine-operating-system @@ -132,7 +134,8 @@ (define (mapping->file-system mapping) (check? #f) (create-mount-point? #t))))) -(define* (virtualized-operating-system os mappings +(define* (virtualized-operating-system os + #:optional (mappings '()) #:key (full-boot? #f) volatile?) "Return an operating system based on OS suitable for use in a virtualized environment with the store shared with the host. MAPPINGS is a list of @@ -316,6 +319,63 @@ (define* (system-qemu-image/shared-store-script os (gexp->derivation "run-vm.sh" builder))) +(define* (linux-image-startup-command image + #:key + (system (%current-system)) + (target #f) + (qemu qemu-minimal) + (graphic? #f) + (cpu "max") + (cpu-count 1) + (memory-size 1024) + (port-forwardings '()) + (date #f)) + "Return a list-valued gexp representing the command to start QEMU to run +IMAGE, assuming it uses the Linux kernel, and not sharing the store with the +host." + (define os + ;; Note: 'image-operating-system' would return the wrong OS, before + ;; its root partition has been assigned a UUID. + (operating-system-for-image image)) + + (define kernel-arguments + #~(list #$@(if graphic? #~() #~("console=ttyS0")) + #+@(operating-system-kernel-arguments os "/dev/vda1"))) + + #~`(#+(file-append qemu "/bin/" + (qemu-command (or target system))) + ,@(if (access? "/dev/kvm" (logior R_OK W_OK)) + '("-enable-kvm") + '()) + + "-cpu" #$cpu + #$@(if (> cpu-count 1) + #~("-smp" #$(string-append "cpus=" (number->string cpu-count))) + #~()) + "-m" #$(number->string memory-size) + "-nic" #$(string-append + "user,model=virtio-net-pci," + (port-forwardings->qemu-options port-forwardings)) + "-kernel" #$(operating-system-kernel-file os) + "-initrd" #$(file-append os "/initrd") + "-append" ,(string-join #$kernel-arguments) + "-serial" "stdio" + + #$@(if date + #~("-rtc" + #$(string-append "base=" (date->string date "~5"))) + #~()) + + "-object" "rng-random,filename=/dev/urandom,id=guix-vm-rng" + "-device" "virtio-rng-pci,rng=guix-vm-rng" + + "-drive" + ,(string-append "file=" #$(system-image image) + ",format=qcow2,if=virtio," + "cache=writeback,werror=report,readonly=off") + "-snapshot" + "-no-reboot")) + ;;; ;;; High-level abstraction. diff --git a/gnu/tests/virtualization.scm b/gnu/tests/virtualization.scm index 6ca88cbacd..c8b42eb1db 100644 --- a/gnu/tests/virtualization.scm +++ b/gnu/tests/virtualization.scm @@ -33,6 +33,7 @@ (define-module (gnu tests virtualization) #:use-module (gnu services) #:use-module (gnu services dbus) #:use-module (gnu services networking) + #:use-module (gnu services ssh) #:use-module (gnu services virtualization) #:use-module (gnu packages ssh) #:use-module (gnu packages virtualization) @@ -42,7 +43,8 @@ (define-module (gnu tests virtualization) #:use-module (guix modules) #:export (%test-libvirt %test-qemu-guest-agent - %test-childhurd)) + %test-childhurd + %test-build-vm)) ;;; @@ -241,6 +243,36 @@ (define %childhurd-os (password "")) ;empty password %base-user-accounts)))))))) +(define* (run-command-over-ssh command + #:key (port 10022) (user "test")) + "Return a program that runs COMMAND over SSH and prints the result on standard +output." + (define run + (with-extensions (list guile-ssh) + #~(begin + (use-modules (ssh session) + (ssh auth) + (ssh popen) + (ice-9 match) + (ice-9 textual-ports)) + + (let ((session (make-session #:user #$user + #:port #$port + #:host "localhost" + #:timeout 120 + #:log-verbosity 'rare))) + (match (connect! session) + ('ok + (userauth-password! session "") + (display + (get-string-all + (open-remote-input-pipe* session #$@command)))) + (status + (error "could not connect to guest over SSH" + session status))))))) + + (program-file "run-command-over-ssh" run)) + (define (run-childhurd-test) (define (import-module? module) ;; This module is optional and depends on Guile-Gcrypt, do skip it. @@ -261,36 +293,6 @@ (define (run-childhurd-test) (operating-system os) (memory-size (* 1024 3)))) - (define (run-command-over-ssh . command) - ;; Program that runs COMMAND over SSH and prints the result on standard - ;; output. - (let () - (define run - (with-extensions (list guile-ssh) - #~(begin - (use-modules (ssh session) - (ssh auth) - (ssh popen) - (ice-9 match) - (ice-9 textual-ports)) - - (let ((session (make-session #:user "test" - #:port 10022 - #:host "localhost" - #:timeout 120 - #:log-verbosity 'rare))) - (match (connect! session) - ('ok - (userauth-password! session "") - (display - (get-string-all - (open-remote-input-pipe* session #$@command)))) - (status - (error "could not connect to childhurd over SSH" - session status))))))) - - (program-file "run-command-over-ssh" run))) - (define test (with-imported-modules '((gnu build marionette)) #~(begin @@ -356,21 +358,24 @@ (define (run-childhurd-test) ;; 'uname' command. (marionette-eval '(begin - (use-modules (ice-9 popen)) + (use-modules (ice-9 popen) + (ice-9 textual-ports)) (get-string-all - (open-input-pipe #$(run-command-over-ssh "uname" "-on")))) + (open-input-pipe #$(run-command-over-ssh '("uname" "-on"))))) marionette)) (test-assert "guix-daemon up and running" (let ((drv (marionette-eval '(begin - (use-modules (ice-9 popen)) + (use-modules (ice-9 popen) + (ice-9 textual-ports)) (get-string-all (open-input-pipe - #$(run-command-over-ssh "guix" "build" "coreutils" - "--no-grafts" "-d")))) + #$(run-command-over-ssh + '("guix" "build" "coreutils" + "--no-grafts" "-d"))))) marionette))) ;; We cannot compare the .drv with (raw-derivation-file ;; coreutils) on the host: they may differ due to fixed-output @@ -416,3 +421,102 @@ (define %test-childhurd "Connect to the GNU/Hurd virtual machine service, aka. a childhurd, making sure that the childhurd boots and runs its SSH server.") (value (run-childhurd-test)))) + + +;;; +;;; Virtual build machine. +;;; + +(define %build-vm-os + (simple-operating-system + (service virtual-build-machine-service-type + (virtual-build-machine + (cpu-count 1) + (memory-size (* 1 1024)))))) + +(define (run-build-vm-test) + (define (import-module? module) + ;; This module is optional and depends on Guile-Gcrypt, do skip it. + (and (guix-module-name? module) + (not (equal? module '(guix store deduplication))))) + + (define os + (marionette-operating-system + %build-vm-os + #:imported-modules (source-module-closure + '((gnu services herd) + (gnu build install)) + #:select? import-module?))) + + (define vm + (virtual-machine + (operating-system os) + (memory-size (* 1024 3)))) + + (define test + (with-imported-modules '((gnu build marionette)) + #~(begin + (use-modules (gnu build marionette) + (srfi srfi-64) + (ice-9 match)) + + (define marionette + ;; Emulate as much as the host CPU supports so that, possibly, KVM + ;; is available inside as well ("nested KVM"), provided + ;; /sys/module/kvm_intel/parameters/nested (or similar) allows it. + (make-marionette (list #$vm "-cpu" "max"))) + + (test-runner-current (system-test-runner #$output)) + (test-begin "build-vm") + + (test-assert "service running" + (marionette-eval + '(begin + (use-modules (gnu services herd) + (ice-9 match)) + + (start-service 'build-vm)) + marionette)) + + (test-assert "guest SSH up and running" + ;; Note: Pass #:peek? #t because due to the way QEMU port + ;; forwarding works, connecting to 11022 always works even if the + ;; 'sshd' service hasn't been started yet in the guest. + (wait-for-tcp-port 11022 marionette + #:peek? #t)) + + (test-assert "copy-on-write store" + ;; Set up a writable store. The root partition is already an + ;; overlayfs, which is not suitable as the bottom part of this + ;; additional overlayfs; thus, create a tmpfs for the backing + ;; store. + ;; TODO: Remove this when creates a writable + ;; store. + (marionette-eval + '(begin + (use-modules (gnu build install) + (guix build syscalls)) + + (mkdir "/run/writable-store") + (mount "none" "/run/writable-store" "tmpfs") + (mount-cow-store "/run/writable-store" "/backing-store") + (system* "df" "-hT")) + marionette)) + + (test-equal "offloading" + 0 + (marionette-eval + '(and (file-exists? "/etc/guix/machines.scm") + (system* "guix" "offload" "test")) + marionette)) + + (test-end)))) + + (gexp->derivation "build-vm-test" test)) + +(define %test-build-vm + (system-test + (name "build-vm") + (description + "Offload to a virtual build machine over SSH.") + (value (run-build-vm-test))))