From patchwork Mon Feb 24 12:45:51 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: 39110 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 20EE827BBEA; Mon, 24 Feb 2025 12:47:47 +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 1C0F327BBE2 for ; Mon, 24 Feb 2025 12:47:46 +0000 (GMT) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1tmXrk-0002Ze-Ah; Mon, 24 Feb 2025 07:47:20 -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 1tmXrd-0002SH-5B for guix-patches@gnu.org; Mon, 24 Feb 2025 07:47:14 -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 1tmXrT-0000nu-SE for guix-patches@gnu.org; Mon, 24 Feb 2025 07:47:05 -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=1NCGw/GYXWAUUurlh8RDc1xcbMfNVpuHDJMLmLaev3Q=; b=VViTJh+8SCa/EBso8TxNFJmYVtm3V4+R+xT3FkiXNuT34uH9YFLfVfKkTR/6oZOLwTrMdfJq15J+mS3OsuCNJ7misClmyKG5r6Yrvagluu2WR1OzgoDjG6br1JLG5Lgwm5KciXWqjDzZR4G54n4k62R0xIEz1NafeVLpdmmYpmsARMVXMCpBLwnObwxelCpCswHdcti0UbvTeW1rqQT/9Me5BMMUKg6bemeRV70qiPzdbZLvr+p3ILYwcBJyhwbojlPbu2o5Q0TNmWtBiDAzJhuVsYZhiKS937PKIp2Y6rbhMUFLm9nTHgmwjQ4c6aXz3xnOt9BGXpldgsE9yWkbNw==; Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1tmXrT-00041W-Nh for guix-patches@gnu.org; Mon, 24 Feb 2025 07:47:03 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#76488] [PATCH v2 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: Mon, 24 Feb 2025 12:47: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.174040120015399 (code B ref 76488); Mon, 24 Feb 2025 12:47:03 +0000 Received: (at 76488) by debbugs.gnu.org; 24 Feb 2025 12:46:40 +0000 Received: from localhost ([127.0.0.1]:38864 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1tmXr5-00040G-UO for submit@debbugs.gnu.org; Mon, 24 Feb 2025 07:46:40 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]:33018) by debbugs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.84_2) (envelope-from ) id 1tmXqt-0003z6-7r for 76488@debbugs.gnu.org; Mon, 24 Feb 2025 07:46:28 -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 1tmXqj-0000ki-8p; Mon, 24 Feb 2025 07:46:21 -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=1NCGw/GYXWAUUurlh8RDc1xcbMfNVpuHDJMLmLaev3Q=; b=m/4OBMRu0P81OQZxoW50 Y3/WWeeOgiS8203p3FTtsjUuLmoTXu1S2wYMcQ0pIKBL2TNweEE3Ujrk4uFZhoBuvay94IWwC7AKL eQzx/8gNcW/OpTuLuI5PgSnn1cuxeawU5mS71CeeNsWB47Lu8I2G9AvXro1C7hILX7wDfuRqyYwxa +04LO+qgXdp82BprC3/FPDIukRWfQbmZIdwDmJGROT8bcKyjVH9IYusQksvWAeg+ep3/+V8D3H51o isoM70epUvZXkoPlh5wwCgJGScVsFOlkYgL9sTyiIk6NbDKrl520zeYmF9QdYJHUjhoDxSt8h6qSn eRzVQWCBPKbi8g==; From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Mon, 24 Feb 2025 13:45:51 +0100 Message-ID: <742467b923f62ae257eda4e32893a1d0b144e8f6.1740400981.git.ludo@gnu.org> 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 | 379 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 380 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..a08622424a7 --- /dev/null +++ b/gnu/tests/foreign.scm @@ -0,0 +1,379 @@ +;;; 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) + #:export (%test-debian-install)) + +(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") + #:keep-mtime? #t)) + 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-assert "/etc/os-release" + (marionette-eval '(begin + (use-modules (ice-9 textual-ports)) + (call-with-input-file "/etc/os-release" + get-string-all)) + 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-equal "create user account" + 0 + (marionette-eval '(system* "useradd" "-d" "/home/user" "-m" + "user") + marionette)) + + (test-equal "guix install hello, unprivileged user" + 0 + ;; Check that 'guix' is in $PATH for new users and that + ;; ~user/.guix-profile also gets created. + (marionette-eval '(system "su - user -c \ +'guix install hello --no-grafts --bootstrap'") + marionette)) + + (test-equal "user hello" + 0 + (marionette-eval '(system "~user/.guix-profile/bin/hello") + marionette)) + + (test-equal "unprivileged user profile created" + 0 + (marionette-eval '(system "ls -lad ~user/.guix-profile") + marionette)) + + (test-equal "store is read-only" + EROFS + (marionette-eval '(catch 'system-error + (lambda () + (mkdir (in-vicinity #$(%store-prefix) + "whatever")) + 0) + (lambda args + (system-error-errno args))) + 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/20250210-2019/debian-12-nocloud-amd64-20250210-2019.qcow2") + (method url-fetch) + (sha256 + (base32 + "06vlcq2dzgczlyp9lfkkdf3dgvfjp22lh5xz0mnl0bdgzq61sykb")))) + +(define %test-debian-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))))