From patchwork Sat Feb 22 17:10:16 2025 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: 38982 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 DBE4827BBEA; Sat, 22 Feb 2025 17:11:38 +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=-7.6 required=5.0 tests=BAYES_00,DKIMWL_WL_HIGH, DKIM_SIGNED,DKIM_VALID,MAILING_LIST_MULTI,RCVD_IN_DNSWL_BLOCKED, RCVD_IN_VALIDITY_CERTIFIED,RCVD_IN_VALIDITY_RPBL,RCVD_IN_VALIDITY_SAFE, 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 E361F27BBE2 for ; Sat, 22 Feb 2025 17:11:37 +0000 (GMT) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1tlt1v-0003J8-84; Sat, 22 Feb 2025 12:11:07 -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 1tlt1s-0003IS-4Y for guix-patches@gnu.org; Sat, 22 Feb 2025 12:11:04 -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 1tlt1r-0004NW-Kb for guix-patches@gnu.org; Sat, 22 Feb 2025 12:11:03 -0500 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=debbugs.gnu.org; s=debbugs-gnu-org; h=MIME-Version:References:In-Reply-To:Date:From:To:Subject; bh=9lxNSCriN0s3RrKYtQo2/cragD6I+7yiy6yfnnojgro=; b=sKr3yHrUk2RtudYgh8mMucJZFwA6ITpv+Ls3jNThCyRRheT26w2bYrVVCLT0al/AjVzY+exrL6W+BRTAiLJgnB3A+NCvMlcxqa2pR9w9HV0pVbxIqcFdUiD35lXt6WGxrX3U4jZv41Px6h/8e6tD5ph+U/hXQT9iCGafIuN5reGDFwwxMBEGckujgn41no47hlx/48IjqPBgzvWa0/85F8mtEljZKQqPNyibJ1UHucNxoaKzWCfL1u79ITRnBZBFCIEi5GrEXDXYuAKIhhUyogTBhuEd0ZqtXkchGDwLoo3bs4IndnfTUoZCnqwLZhWGaBaw3gKAfoLUN1mcZy7Smw==; Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1tlt1r-0002Em-GL for guix-patches@gnu.org; Sat, 22 Feb 2025 12:11:03 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#76488] [PATCH 4/4] tests: Test installation on Debian. Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Sat, 22 Feb 2025 17:11:03 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 76488 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 76488@debbugs.gnu.org Cc: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 76488-submit@debbugs.gnu.org id=B76488.17402442488553 (code B ref 76488); Sat, 22 Feb 2025 17:11:03 +0000 Received: (at 76488) by debbugs.gnu.org; 22 Feb 2025 17:10:48 +0000 Received: from localhost ([127.0.0.1]:57045 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1tlt1b-0002Dj-84 for submit@debbugs.gnu.org; Sat, 22 Feb 2025 12:10:48 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]:58966) by debbugs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.84_2) (envelope-from ) id 1tlt1T-0002Cm-RB for 76488@debbugs.gnu.org; Sat, 22 Feb 2025 12:10:40 -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 1tlt1O-0004LT-Gi; Sat, 22 Feb 2025 12:10:34 -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=9lxNSCriN0s3RrKYtQo2/cragD6I+7yiy6yfnnojgro=; b=QxXpyJkQcbUbSyIjvv1O OgTdA3j0921lmQBDJoXxbTq6q3M7foQrDx8Q0csXV9zsHZ3FxQ+IYovGdQNFbsx3t0dI64Ax6wel9 3fed6t0uW+NH1Cu8c5e3MdzvNPqbGLYQCdQv3ylILC9fmEZJ09TypQwADXwD1mFIZ5KchYb/sm/DZ nFSZBIVyHJQRu02GjCKR5Z4TW/vS+u8/BXr2j/2NrtUA+DcazhNamsqEIbCp55mugu8diAxk8HufR xcgeLWhUVVCE6xPnKfeaWfO2WmYaittujSgGw4KtPkH2TA1mYcgzC58rf+9F/iH0mX6gBM+mwl6bG +fD3kBNhoZ3gCw==; From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Sat, 22 Feb 2025 18:10:16 +0100 Message-ID: X-Mailer: git-send-email 2.48.1 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/tests/foreign.scm: New file. * gnu/local.mk (GNU_SYSTEM_MODULES): Add it. Change-Id: I1f24d83bdc298acbef15db2e19775cc1d3fbd56c --- gnu/local.mk | 1 + gnu/tests/foreign.scm | 337 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 338 insertions(+) create mode 100644 gnu/tests/foreign.scm diff --git a/gnu/local.mk b/gnu/local.mk index c421da85cba..66cca59839e 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -848,6 +848,7 @@ GNU_SYSTEM_MODULES = \ %D%/tests/docker.scm \ %D%/tests/emacs.scm \ %D%/tests/file-sharing.scm \ + %D%/tests/foreign.scm \ %D%/tests/ganeti.scm \ %D%/tests/gdm.scm \ %D%/tests/guix.scm \ diff --git a/gnu/tests/foreign.scm b/gnu/tests/foreign.scm new file mode 100644 index 00000000000..8cf580cb22d --- /dev/null +++ b/gnu/tests/foreign.scm @@ -0,0 +1,337 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2025 Ludovic Courtès +;;; +;;; 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 . + +(define-module (gnu tests foreign) + #:use-module (guix download) + #:use-module (guix gexp) + #:use-module (guix modules) + #:use-module (guix monads) + #:use-module (guix packages) + #:use-module (guix profiles) + #:autoload (guix store) (%store-prefix %store-monad %graft?) + #:use-module (gnu compression) + #:use-module (gnu tests) + #:use-module (gnu packages base) + #:use-module (gnu packages bootstrap) + #:use-module (gnu packages guile) + #:use-module (gnu packages make-bootstrap) + #:use-module (gnu packages package-management) + #:use-module (gnu packages virtualization) + #:use-module (gnu system vm) + #:use-module ((guix scripts pack) #:prefix pack:) + #:use-module (srfi srfi-9)) + +(define marionette-systemd-service + ;; Definition of the marionette service for systemd. + (plain-file "marionette.service" " +[Unit] +Description=Guix marionette service + +[Install] +WantedBy=multi-user.target + +[Service] +ExecStart=/opt/guix/bin/guile --no-auto-compile \\ + /opt/guix/share/guix/marionette-repl.scm\n")) + +(define* (qcow-image-with-marionette image + #:key + (name "image-with-marionette.qcow2") + (device "/dev/vdb1")) + "Instrument IMAGE, returning a new image that contains a statically-linked +Guile under /opt/guix and a marionette systemd service. The relevant file +system is expected to be on DEVICE." + (define vm + (virtual-machine + (marionette-operating-system %simple-os))) + + (define build + (with-imported-modules (source-module-closure + '((guix build utils) + (gnu build marionette))) + #~(begin + (use-modules (guix build utils) + (gnu build marionette)) + + (define target-image + #$output) + + (invoke #+(file-append qemu "/bin/qemu-img") + "create" "-b" #$image + "-F" "qcow2" "-f" "qcow2" target-image + "10G") + + ;; Run a VM that will mount IMAGE and populate it. This is somewhat + ;; more convenient to set up than 'guestfish' from libguestfs. + (let ((marionette + (make-marionette + (list #$vm "-drive" + (string-append "file=" target-image + ",format=qcow2,if=virtio," + "cache=writeback,werror=report,readonly=off"))))) + + (marionette-eval '(system* "mount" #$device "/mnt") + marionette) + (marionette-eval '(system* "ls" "-la" "/mnt") + marionette) + (marionette-eval '(begin + (use-modules (guix build utils)) + (mkdir-p "/mnt/opt/guix") + (copy-recursively #$%guile-static-initrd + "/mnt/opt/guix" + #:log (%make-void-port "w"))) + marionette) + (marionette-eval '(system* "/mnt/opt/guix/bin/guile" "--version") + marionette) + (unless (= 42 (status:exit-val + (marionette-eval '(system* "/mnt/opt/guix/bin/guile" + "-c" "(exit 42)") + marionette))) + (error "statically-linked Guile is broken")) + + ;; Install the marionette systemd service and activate it. + (marionette-eval '(begin + (mkdir-p "/mnt/opt/guix/share/guix") + (copy-file #$(marionette-program) + "/mnt/opt/guix/share/guix/marionette-repl.scm") + + (mkdir-p "/mnt/etc/systemd/system") + (copy-file #$marionette-systemd-service + "/mnt/etc/systemd/system/marionette.service") + + ;; Activate the service, as per 'systemctl + ;; enable marionette.service'. + (symlink + "/etc/systemd/system/marionette.service" + "/mnt/etc/systemd/system/multi-user.target.wants/marionette.service")) + marionette) + + (unless (zero? (marionette-eval '(system* "umount" "/mnt") + marionette)) + (error "failed to unmount device")))))) + + (computed-file name build)) + +(define (manifest-entry-without-grafts entry) + "Return ENTRY with grafts disabled on its contents." + (manifest-entry + (inherit entry) + (item (with-parameters ((%graft? #f)) + (manifest-entry-item entry))))) + +(define %installation-tarball-manifest + ;; Manifest of the Guix installation tarball. + (concatenate-manifests + (list (packages->manifest (list guix)) + + ;; Include the dependencies of 'hello' in addition to 'guix' so that + ;; we can test 'guix build hello'. + (map-manifest-entries + manifest-entry-without-grafts + (package->development-manifest hello)) + + ;; Add the source of 'hello'. + (manifest + (list (manifest-entry + (name "hello-source") + (version (package-version hello)) + (item (let ((file (origin-actual-file-name + (package-source hello)))) + (computed-file + "hello-source" + #~(begin + ;; Put the tarball in a subdirectory since + ;; profile union crashes otherwise. + (mkdir #$output) + (mkdir (in-vicinity #$output "src")) + (symlink #$(package-source hello) + (in-vicinity #$output + (string-append "src/" + #$file)))))))))) + + ;; Include 'guile-final', which is needed when building derivations + ;; such as that of 'hello' but missing from the development manifest. + ;; Add '%bootstrap-guile', used by 'guix install --bootstrap'. + (map-manifest-entries + manifest-entry-without-grafts + (packages->manifest (list (canonical-package guile-3.0) + %bootstrap-guile)))))) + +(define %guix-install-script + ;; The 'guix-install.sh' script. + ;; + ;; To test local changes, replace the expression below with: + ;; + ;; (local-file "../../etc/guix-install.sh") + ;; + ;; This cannot be done unconditionally since that file does not exists in + ;; inferiors. + (file-append (package-source guix) "/etc/guix-install.sh")) + +(define (run-foreign-install-test image name) + "Run an installation of Guix in IMAGE, the QCOW2 image of a systemd-based +GNU/Linux distro, and check that the installation is functional." + (define instrumented-image + (qcow-image-with-marionette image + #:name (string-append name ".qcow2"))) + + (define (test tarball) + (with-imported-modules (source-module-closure + '((gnu build marionette) + (gnu system file-systems))) + #~(begin + (use-modules (gnu build marionette) + (gnu system file-systems) + (srfi srfi-64) + (ice-9 match)) + + (define marionette + (make-marionette + (list (string-append #$qemu-minimal "/bin/" (qemu-command)) + #$@(common-qemu-options instrumented-image + (list (%store-prefix)) + #:image-format "qcow2" + #:rw-image? #t) + "-m" "512" + "-snapshot"))) + + (test-runner-current (system-test-runner #$output)) + (test-begin "foreign-install") + + (test-equal "marionette works" + "Linux" + (marionette-eval '(utsname:sysname (uname)) + marionette)) + + (test-equal "mount host file store" + 0 + (marionette-eval + '(begin + (mkdir "/host") + (system* "mount" "-t" "9p" + "-o" "trans=virtio,cache=loose,ro" + #$(file-system->mount-tag (%store-prefix)) + "/host")) + marionette)) + + (test-assert "screenshot before" + (marionette-control (string-append "screendump " #$output + "/before-install.ppm") + marionette)) + + (test-assert "install fake dependencies" + ;; The installation script insists on checking for the + ;; availability of 'wget' and 'gpg' but does not actually use them + ;; when 'GUIX_BINARY_FILE_NAME' is set. Provide fake binaries. + (marionette-eval '(begin + (symlink "/bin/true" "/bin/wget") + (symlink "/bin/true" "/bin/gpg") + #t) + marionette)) + + (test-assert "run install script" + (marionette-eval '(system + (string-append + "yes '' | GUIX_BINARY_FILE_NAME=" + (in-vicinity "/host" + (basename #$tarball)) + " sh " + (in-vicinity + "/host" + (string-drop #$%guix-install-script + #$(string-length + (%store-prefix)))))) + marionette)) + + (test-equal "hello not already built" + #f + ;; Check that the next test will really build 'hello'. + (marionette-eval '(file-exists? + #$(with-parameters ((%graft? #f)) + hello)) + marionette)) + + (test-equal "guix build hello" + 0 + ;; Check that guix-daemon is up and running and that the build + ;; environment is properly set up (build users, etc.). + (marionette-eval '(system* "guix" "build" "hello" "--no-grafts") + marionette)) + + (test-assert "hello indeed built" + (marionette-eval '(file-exists? + #$(with-parameters ((%graft? #f)) + hello)) + marionette)) + + (test-equal "guix install hello" + 0 + ;; Check that ~/.guix-profile & co. are properly created. + (marionette-eval '(let ((pw (getpwuid (getuid)))) + (setenv "USER" (passwd:name pw)) + (setenv "HOME" (pk 'home (passwd:dir pw))) + (system* "guix" "install" "hello" + "--no-grafts" "--bootstrap")) + marionette)) + + (test-equal "user profile created" + 0 + (marionette-eval '(system "ls -lad ~/.guix-profile") + marionette)) + + (test-equal "hello" + 0 + (marionette-eval '(system "~/.guix-profile/bin/hello") + marionette)) + + (test-assert "screenshot after" + (marionette-control (string-append "screendump " #$output + "/after-install.ppm") + marionette)) + + (test-end)))) + + (mlet* %store-monad ((profile (profile-derivation + %installation-tarball-manifest)) + (tarball (pack:self-contained-tarball + "guix-binary" profile + #:compressor (lookup-compressor "zstd") + #:profile-name "current-guix" + #:localstatedir? #t))) + (gexp->derivation name (test tarball)))) + +(define debian-12-qcow2 + ;; Image taken from . + ;; XXX: Those images are periodically removed from debian.org. + (origin + (uri + "https://cloud.debian.org/images/cloud/bookworm/latest/debian-12-nocloud-amd64.qcow2") + (method url-fetch) + (sha256 + (base32 + "06vlcq2dzgczlyp9lfkkdf3dgvfjp22lh5xz0mnl0bdgzq61sykb")))) + +(define %test-foreign-install + (system-test + (name "debian-install") + (description + "Test installation of Guix on Debian using the @file{guix-install.sh} +script.") + (value (run-foreign-install-test debian-12-qcow2 name)))) + +%test-foreign-install