From patchwork Wed May 27 07:24:20 2020 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Mathieu Othacehe X-Patchwork-Id: 22404 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 3083627BBE3; Wed, 27 May 2020 08:25:16 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.8 required=5.0 tests=BAYES_00,DKIM_ADSP_CUSTOM_MED, DKIM_SIGNED,FREEMAIL_FROM,MAILING_LIST_MULTI,RCVD_IN_MSPIKE_H4, RCVD_IN_MSPIKE_WL,T_DKIM_INVALID autolearn=unavailable autolearn_force=no version=3.4.2 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTP id CE1F027BBE1 for ; Wed, 27 May 2020 08:25:14 +0100 (BST) Received: from localhost ([::1]:32888 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1jdqR8-0005Ai-Bu for patchwork@mira.cbaines.net; Wed, 27 May 2020 03:25:14 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:41882) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1jdqQz-00052W-AS for guix-patches@gnu.org; Wed, 27 May 2020 03:25:05 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:36551) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1jdqQz-0001Ax-0p for guix-patches@gnu.org; Wed, 27 May 2020 03:25:05 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1jdqQy-0003iV-Ty for guix-patches@gnu.org; Wed, 27 May 2020 03:25:04 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#41560] [PATCH 8/8] image: Do not use VM to create disk-images. Resent-From: Mathieu Othacehe Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Wed, 27 May 2020 07:25:04 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 41560 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 41560@debbugs.gnu.org Cc: Mathieu Othacehe Received: via spool by 41560-submit@debbugs.gnu.org id=B41560.159056429214212 (code B ref 41560); Wed, 27 May 2020 07:25:04 +0000 Received: (at 41560) by debbugs.gnu.org; 27 May 2020 07:24:52 +0000 Received: from localhost ([127.0.0.1]:48090 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1jdqQl-0003h5-F7 for submit@debbugs.gnu.org; Wed, 27 May 2020 03:24:52 -0400 Received: from mail-wr1-f49.google.com ([209.85.221.49]:33650) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1jdqQd-0003fo-KT for 41560@debbugs.gnu.org; Wed, 27 May 2020 03:24:44 -0400 Received: by mail-wr1-f49.google.com with SMTP id l11so22988716wru.0 for <41560@debbugs.gnu.org>; Wed, 27 May 2020 00:24:43 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20161025; h=from:to:cc:subject:date:message-id:in-reply-to:references :mime-version:content-transfer-encoding; bh=paz5aa8d9pDTg5ShCsmQGGaRtrZCL9Oz/b4rpsYekrU=; b=aHnKPRAcwP7QEYC3LsrVcwM3Q3tC9QDXyYlRgspY3NmngtnBLoGcSADmBBYl0tM1Bo 188MrVB8CpoKpf3UT1JdlhuaVhEYlrtfPTtHgkJP3xf/wa0SEqlOIoQYAfWl0Y362W7o owGCivusEaPUZZvf+3vH2sC6cfwLNpWegBZEK5q6aBYcnMP/bpA5RlQjJ2Akg0uV7CGj dYkMrsfhrs/ZTjNxfor+NMN5UvmZqij7JKFdtCeEVsBUXeQAEL2Y7pXx5VNkk53D6HHs tlMKB/tv1PMSIZc24kfPRx14XywjAQWj4XQ+GtJ01oP9rp92FM2/60z5hgwdG2GaVPg9 vFVw== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20161025; h=x-gm-message-state:from:to:cc:subject:date:message-id:in-reply-to :references:mime-version:content-transfer-encoding; bh=paz5aa8d9pDTg5ShCsmQGGaRtrZCL9Oz/b4rpsYekrU=; b=mZSu1Ixs1D+TtyMQII8YW2r7fkG+cB38db644VRUMdnOpF6dYS/pEWOrZo+0SCAoXE /02SIcK1OOx3z+PX+nzXmy54jR8SYJHcQTxJUrCX9VLEPKVwL8tI8tPfqG/NNYJB1BcI 50aeFyQWQJygEw9DMt45Fmfsokm0DbJGTkV6umIMWL6/mudT3jkS49jsDahr06n9j1As Zo7nM+KR71OgEz6cViTwoAWBmCpL4VCy5zDW5DtBprpUXysR55A8OwaqsfZs8Gr7rRo6 S57YixmZqgvdc8+Qxq7vTMcMBG5Tg9s8pg6TkRDX87NaTMAJGyzpkNo6/vp5SXTYPvIy gPiw== X-Gm-Message-State: AOAM532b7/rZCA/xiWN4H745gdnwhz+jHhBwA4AzZ+4UOvGTbvKU+Zqs i2kNlml8IQ9RBjaWoM7Wnimh1ZPNdK0= X-Google-Smtp-Source: ABdhPJygfTRDRxVXei9H20fMTP/hwvgBkmTbNuI9MU5xx6YDzt0bbQ+wJz/d6gq9Hb29kaGUWsGaPw== X-Received: by 2002:a5d:5006:: with SMTP id e6mr23345355wrt.170.1590564277420; Wed, 27 May 2020 00:24:37 -0700 (PDT) Received: from meru.fronius.com ([2a01:e0a:fa:a50:e5a2:3f70:d249:6ce9]) by smtp.gmail.com with ESMTPSA id v28sm2002845wra.77.2020.05.27.00.24.36 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Wed, 27 May 2020 00:24:36 -0700 (PDT) From: Mathieu Othacehe X-Google-Original-From: Mathieu Othacehe Date: Wed, 27 May 2020 09:24:20 +0200 Message-Id: <20200527072420.26140-8-othacehe@gnu.org> X-Mailer: git-send-email 2.26.2 In-Reply-To: <20200527072420.26140-1-othacehe@gnu.org> References: <20200527072420.26140-1-othacehe@gnu.org> 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" X-getmail-retrieved-from-mailbox: Patches Now that installing Grub on raw disk-images is supported, we do not need to rely on (gnu system vm) module. * gnu/system/image.scm (make-system-image): Rename to ... (system-image): ... this, and remove the compatibility wrapper. (find-image): Turn to a monadic procedure. This will become useful when introducing Hurd support, to be able to detect the target system. * gnu/ci.scm (qemu-jobs): Use lower-object now that system-image returns a file-like object. * gnu/tests/install.scm (run-install): Ditto. * guix/scripts/system.scm (system-derivation-for-action): Add a 'base-image' argument, (perform-action): adapt accordingly. --- gnu/ci.scm | 20 +++++++++++--------- gnu/system/image.scm | 40 ++++++---------------------------------- gnu/tests/install.scm | 8 ++++---- guix/scripts/system.scm | 16 +++++++++------- 4 files changed, 30 insertions(+), 54 deletions(-) diff --git a/gnu/ci.scm b/gnu/ci.scm index b61181be51..fa67168e22 100644 --- a/gnu/ci.scm +++ b/gnu/ci.scm @@ -219,19 +219,21 @@ system.") (run-with-store store (mbegin %store-monad (set-guile-for-build (default-guile)) - (system-image - (image - (inherit efi-disk-image) - (size (* 1500 MiB)) - (operating-system installation-os)))))) + (lower-object + (system-image + (image + (inherit efi-disk-image) + (size (* 1500 MiB)) + (operating-system installation-os))))))) (->job 'iso9660-image (run-with-store store (mbegin %store-monad (set-guile-for-build (default-guile)) - (system-image - (image - (inherit iso9660-image) - (operating-system installation-os))))))) + (lower-object + (system-image + (image + (inherit iso9660-image) + (operating-system installation-os)))))))) '())) (define channel-build-system diff --git a/gnu/system/image.scm b/gnu/system/image.scm index 97124a4699..8bb8412f16 100644 --- a/gnu/system/image.scm +++ b/gnu/system/image.scm @@ -488,7 +488,7 @@ it can be used for bootloading." (type root-file-system-type)) file-systems-to-keep))))) -(define* (make-system-image image) +(define* (system-image image) "Return the derivation of IMAGE. It can be a raw disk-image or an ISO9660 image, depending on IMAGE format." (define substitutable? (image-substitutable? image)) @@ -521,38 +521,10 @@ image, depending on IMAGE format." "Find and return an image that could match the given FILE-SYSTEM-TYPE. This is useful to adapt to interfaces written before the addition of the record." - ;; XXX: Add support for system and target here, or in the caller. - (match file-system-type - ("iso9660" iso9660-image) - (_ efi-disk-image))) - -(define (system-image image) - "Wrap 'make-system-image' call, so that it is used only if the given IMAGE -is supported. Otherwise, fallback to image creation in a VM. This is -temporary and should be removed once 'make-system-image' is able to deal with -all types of images." - (define substitutable? (image-substitutable? image)) - (define volatile-root? (image-volatile-root? image)) - - (let* ((image-os (image-operating-system image)) - (image-root-filesystem-type (image->root-file-system image)) - (bootloader (bootloader-configuration-bootloader - (operating-system-bootloader image-os))) - (bootloader-name (bootloader-name bootloader)) - (size (image-size image)) - (format (image-format image))) - (mbegin %store-monad - (if (and (or (eq? bootloader-name 'grub) - (eq? bootloader-name 'extlinux)) - (eq? format 'disk-image)) - ;; Fallback to image creation in a VM when it is not yet supported - ;; by this module. - (system-disk-image-in-vm image-os - #:disk-image-size size - #:file-system-type image-root-filesystem-type - #:volatile? volatile-root? - #:substitutable? substitutable?) - (lower-object - (make-system-image image)))))) + (mbegin %store-monad + (return + (match file-system-type + ("iso9660" iso9660-image) + (_ efi-disk-image))))) ;;; image.scm ends here diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm index cea26c8ef3..6bd8c7d3d2 100644 --- a/gnu/tests/install.scm +++ b/gnu/tests/install.scm @@ -228,18 +228,18 @@ packages defined in installation-os." (mlet* %store-monad ((_ (set-grafting #f)) (system (current-system)) (target (operating-system-derivation target-os)) + (base-image (find-image + installation-disk-image-file-system-type)) ;; Since the installation system has no network access, ;; we cheat a little bit by adding TARGET to its GC ;; roots. This way, we know 'guix system init' will ;; succeed. Also add guile-final, which is pulled in ;; through provenance.drv and may not always be present. - (image + (image -> (system-image (image - (inherit - (find-image - installation-disk-image-file-system-type)) + (inherit base-image) (size install-size) (operating-system (operating-system-with-gc-roots diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 3efd113ac8..3d7aa77cb7 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -670,7 +670,7 @@ checking this by themselves in their 'check' procedure." ;;; Action. ;;; -(define* (system-derivation-for-action os action +(define* (system-derivation-for-action os base-image action #:key image-size file-system-type full-boot? container-shared-network? mappings) @@ -694,11 +694,12 @@ checking this by themselves in their 'check' procedure." (* 70 (expt 2 20))) #:mappings mappings)) ((disk-image) - (system-image - (image - (inherit (find-image file-system-type)) - (size image-size) - (operating-system os)))) + (lower-object + (system-image + (image + (inherit base-image) + (size image-size) + (operating-system os))))) ((docker-image) (system-docker-image os #:shared-network? container-shared-network?)))) @@ -800,7 +801,8 @@ static checks." (check-initrd-modules os))) (mlet* %store-monad - ((sys (system-derivation-for-action os action + ((image (find-image file-system-type)) + (sys (system-derivation-for-action os image action #:file-system-type file-system-type #:image-size image-size #:full-boot? full-boot?