From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mp1 ([2001:41d0:2:4a6f::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by ms11 with LMTPS id a4SzAiZrCWDDIQAA0tVLHw (envelope-from ) for ; Thu, 21 Jan 2021 11:53:10 +0000 Received: from aspmx1.migadu.com ([2001:41d0:2:4a6f::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by mp1 with LMTPS id AJCGOSVrCWALBAAAbx9fmQ (envelope-from ) for ; Thu, 21 Jan 2021 11:53:09 +0000 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by aspmx1.migadu.com (Postfix) with ESMTPS id 6C68C9402C2 for ; Thu, 21 Jan 2021 11:53:09 +0000 (UTC) Received: from localhost ([::1]:33248 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1l2YWS-0000k0-EE for larch@yhetil.org; Thu, 21 Jan 2021 06:53:08 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]:58086) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1l2YWM-0000je-0z for guix-patches@gnu.org; Thu, 21 Jan 2021 06:53:02 -0500 Received: from debbugs.gnu.org ([209.51.188.43]:45444) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1l2YWL-0002qI-Po for guix-patches@gnu.org; Thu, 21 Jan 2021 06:53:01 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1l2YWL-000719-OR for guix-patches@gnu.org; Thu, 21 Jan 2021 06:53:01 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#46017] [PATCH v2] scripts: system: Accept records as input. References: <20210121113751.72613-1-othacehe@gnu.org> In-Reply-To: <20210121113751.72613-1-othacehe@gnu.org> Resent-From: Mathieu Othacehe Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Thu, 21 Jan 2021 11:53:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 46017 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 46017@debbugs.gnu.org Received: via spool by 46017-submit@debbugs.gnu.org id=B46017.161122995726942 (code B ref 46017); Thu, 21 Jan 2021 11:53:01 +0000 Received: (at 46017) by debbugs.gnu.org; 21 Jan 2021 11:52:37 +0000 Received: from localhost ([127.0.0.1]:56990 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1l2YVw-00070T-Jp for submit@debbugs.gnu.org; Thu, 21 Jan 2021 06:52:37 -0500 Received: from eggs.gnu.org ([209.51.188.92]:36646) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1l2YVu-00070H-VS for 46017@debbugs.gnu.org; Thu, 21 Jan 2021 06:52:35 -0500 Received: from fencepost.gnu.org ([2001:470:142:3::e]:40727) by eggs.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1l2YVp-0002b7-O1 for 46017@debbugs.gnu.org; Thu, 21 Jan 2021 06:52:29 -0500 Received: from [2a01:e0a:19b:d9a0:98b7:b002:9499:5e2c] (port=44536 helo=localhost.localdomain) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1l2YVo-0003Hs-Sx; Thu, 21 Jan 2021 06:52:29 -0500 From: Mathieu Othacehe Date: Thu, 21 Jan 2021 12:52:24 +0100 Message-Id: <20210121115224.74425-1-othacehe@gnu.org> X-Mailer: git-send-email 2.29.2 MIME-Version: 1.0 Content-Transfer-Encoding: 8bit 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: , Cc: Mathieu Othacehe Errors-To: guix-patches-bounces+larch=yhetil.org@gnu.org Sender: "Guix-patches" X-Migadu-Flow: FLOW_IN X-Migadu-Spam-Score: 2.15 Authentication-Results: aspmx1.migadu.com; dkim=none; dmarc=pass (policy=none) header.from=gnu.org; spf=pass (aspmx1.migadu.com: domain of guix-patches-bounces@gnu.org designates 209.51.188.17 as permitted sender) smtp.mailfrom=guix-patches-bounces@gnu.org X-Migadu-Queue-Id: 6C68C9402C2 X-Spam-Score: 2.15 X-Migadu-Scanner: scn1.migadu.com X-TUID: Uzv6OYEPwnRM * guix/scripts/system.scm (system-derivation-for-action): Replace "os" argument by "image". Remove "image-size", "image-type", "label" and "volatile-root?" arguments. (perform-action): Ditto. (process-action): Construct the record and pass it to "perform-action" procedure. * tests/guix-system.sh: Adapt accordingly. * gnu/system/images/hurd.scm: Return the default image. * gnu/system/images/novena.scm: Ditto. * gnu/system/images/pine64.scm: Ditto. * gnu/system/images/pinebook-pro.scm Ditto. --- Hello, Here's a v2 that's also removing the "image-size" argument. Thanks, Mathieu gnu/system/images/hurd.scm | 3 + gnu/system/images/novena.scm | 3 + gnu/system/images/pine64.scm | 3 + gnu/system/images/pinebook-pro.scm | 3 + guix/scripts/system.scm | 132 ++++++++++++++--------------- tests/guix-system.sh | 7 +- 6 files changed, 80 insertions(+), 71 deletions(-) diff --git a/gnu/system/images/hurd.scm b/gnu/system/images/hurd.scm index 4417952c5d..eac5b7f7e6 100644 --- a/gnu/system/images/hurd.scm +++ b/gnu/system/images/hurd.scm @@ -111,3 +111,6 @@ (inherit (os->image hurd-barebones-os #:type hurd-qcow2-image-type)) (name 'hurd-barebones.qcow2))) + +;; Return the default image. +hurd-barebones-qcow2-image diff --git a/gnu/system/images/novena.scm b/gnu/system/images/novena.scm index dfaf2c60ee..1cd724ff88 100644 --- a/gnu/system/images/novena.scm +++ b/gnu/system/images/novena.scm @@ -59,3 +59,6 @@ (inherit (os->image novena-barebones-os #:type novena-image-type)) (name 'novena-barebones-raw-image))) + +;; Return the default image. +novena-barebones-raw-image diff --git a/gnu/system/images/pine64.scm b/gnu/system/images/pine64.scm index 63b31399a5..613acd5cfd 100644 --- a/gnu/system/images/pine64.scm +++ b/gnu/system/images/pine64.scm @@ -64,3 +64,6 @@ (inherit (os->image pine64-barebones-os #:type pine64-image-type)) (name 'pine64-barebones-raw-image))) + +;; Return the default image. +pine64-barebones-raw-image diff --git a/gnu/system/images/pinebook-pro.scm b/gnu/system/images/pinebook-pro.scm index 22997fd742..b56a7ea409 100644 --- a/gnu/system/images/pinebook-pro.scm +++ b/gnu/system/images/pinebook-pro.scm @@ -66,3 +66,6 @@ (inherit (os->image pinebook-pro-barebones-os #:type pinebook-pro-image-type)) (name 'pinebook-pro-barebones-raw-image))) + +;; Return the default image. +pinebook-pro-barebones-raw-image diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 9b75ac2fd0..f4743c64ea 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -680,13 +680,15 @@ checking this by themselves in their 'check' procedure." ;;; Action. ;;; -(define* (system-derivation-for-action os action - #:key image-size image-type - full-boot? container-shared-network? - mappings label - volatile-root?) - "Return as a monadic value the derivation for OS according to ACTION." - (mlet %store-monad ((target (current-target-system))) +(define* (system-derivation-for-action image action + #:key + full-boot? + container-shared-network? + mappings) + "Return as a monadic value the derivation for IMAGE according to ACTION." + (mlet %store-monad ((target (current-target-system)) + (os -> (image-operating-system image)) + (image-size -> (image-size image))) (case action ((build init reconfigure) (operating-system-derivation os)) @@ -704,25 +706,11 @@ checking this by themselves in their 'check' procedure." (* 70 (expt 2 20))) #:mappings mappings)) ((image disk-image vm-image) - (let* ((image-type (if (eq? action 'vm-image) - qcow2-image-type - image-type)) - (base-image (os->image os #:type image-type)) - (base-target (image-target base-image))) - (when (eq? action 'disk-image) - (warning (G_ "'disk-image' is deprecated: use 'image' instead~%"))) - (when (eq? action 'vm-image) - (warning (G_ "'vm-image' is deprecated: use 'image' instead~%"))) - (lower-object - (system-image - (image - (inherit (if label - (image-with-label base-image label) - base-image)) - (target (or base-target target)) - (size image-size) - (operating-system os) - (volatile-root? volatile-root?)))))) + (when (eq? action 'disk-image) + (warning (G_ "'disk-image' is deprecated: use 'image' instead~%"))) + (when (eq? action 'vm-image) + (warning (G_ "'vm-image' is deprecated: use 'image' instead~%"))) + (lower-object (system-image image))) ((docker-image) (system-docker-image os #:shared-network? container-shared-network?))))) @@ -768,7 +756,7 @@ and TARGET arguments." (set! %load-compiled-path (lowered-gexp-load-compiled-path lowered)) (return (primitive-eval (lowered-gexp-sexp lowered)))))) -(define* (perform-action action os +(define* (perform-action action image #:key (validate-reconfigure ensure-forward-reconfigure) save-provenance? @@ -776,16 +764,13 @@ and TARGET arguments." install-bootloader? dry-run? derivations-only? use-substitutes? bootloader-target target - image-size image-type - volatile-root? - full-boot? label container-shared-network? + full-boot? + container-shared-network? (mappings '()) (gc-root #f)) - "Perform ACTION for OS. INSTALL-BOOTLOADER? specifies whether to install + "Perform ACTION for IMAGE. INSTALL-BOOTLOADER? specifies whether to install bootloader; BOOTLOADER-TAGET is the target for the bootloader; TARGET is the -target root directory; IMAGE-SIZE is the size of the image to be built, for -the 'image' action. IMAGE-TYPE is the type of image to be built. When -VOLATILE-ROOT? is #t, the root file system is mounted volatile. +target root directory. FULL-BOOT? is used for the 'vm' action; it determines whether to boot directly to the kernel or to the bootloader. CONTAINER-SHARED-NETWORK? @@ -807,6 +792,9 @@ static checks." '() (map boot-parameters->menu-entry (profile-boot-parameters)))) + (define os + (image-operating-system image)) + (define bootloader (operating-system-bootloader os)) @@ -829,11 +817,7 @@ static checks." (check-initrd-modules os))) (mlet* %store-monad - ((sys (system-derivation-for-action os action - #:label label - #:image-type image-type - #:image-size image-size - #:volatile-root? volatile-root? + ((sys (system-derivation-for-action image action #:full-boot? full-boot? #:container-shared-network? container-shared-network? #:mappings mappings)) @@ -1168,9 +1152,9 @@ Some ACTIONS support additional ARGS.\n")) ACTION must be one of the sub-commands that takes an operating system declaration as an argument (a file name.) OPTS is the raw alist of options resulting from command-line parsing." - (define (ensure-operating-system file-or-exp obj) - (unless (operating-system? obj) - (leave (G_ "'~a' does not return an operating system~%") + (define (ensure-operating-system-or-image file-or-exp obj) + (unless (or (operating-system? obj) (image? obj)) + (leave (G_ "'~a' does not return an operating system or an image~%") file-or-exp)) obj) @@ -1184,27 +1168,47 @@ resulting from command-line parsing." (expr (assoc-ref opts 'expression)) (system (assoc-ref opts 'system)) (target (assoc-ref opts 'target)) - (transform (if save-provenance? - (cut operating-system-with-provenance <> file) - identity)) - (os (transform - (ensure-operating-system - (or file expr) - (cond - ((and expr file) - (leave - (G_ "both file and expression cannot be specified~%"))) - (expr - (read/eval expr)) - (file - (load* file %user-module - #:on-error (assoc-ref opts 'on-error))) - (else - (leave (G_ "no configuration specified~%"))))))) - + (transform (lambda (obj) + (if (and save-provenance? (operating-system? obj)) + (operating-system-with-provenance obj file) + obj))) + (obj (transform + (ensure-operating-system-or-image + (or file expr) + (cond + ((and expr file) + (leave + (G_ "both file and expression cannot be specified~%"))) + (expr + (read/eval expr)) + (file + (load* file %user-module + #:on-error (assoc-ref opts 'on-error))) + (else + (leave (G_ "no configuration specified~%"))))))) (dry? (assoc-ref opts 'dry-run?)) (bootloader? (assoc-ref opts 'install-bootloader?)) (label (assoc-ref opts 'label)) + (image-type (lookup-image-type-by-name + (assoc-ref opts 'image-type))) + (image (let* ((image-type (if (eq? action 'vm-image) + qcow2-image-type + image-type)) + (image-size (assoc-ref opts 'image-size)) + (volatile? (assoc-ref opts 'volatile-root?)) + (base-image (if (operating-system? obj) + (os->image obj + #:type image-type) + obj)) + (base-target (image-target base-image))) + (image + (inherit (if label + (image-with-label base-image label) + base-image)) + (target (or base-target target)) + (size image-size) + (volatile-root? volatile?)))) + (os (image-operating-system image)) (target-file (match args ((first second) second) (_ #f))) @@ -1240,7 +1244,7 @@ resulting from command-line parsing." (warn-about-old-distro #:suggested-command "guix system reconfigure")) - (perform-action action os + (perform-action action image #:dry-run? dry? #:derivations-only? (assoc-ref opts 'derivations-only?) @@ -1249,11 +1253,6 @@ resulting from command-line parsing." (assoc-ref opts 'skip-safety-checks?) #:validate-reconfigure (assoc-ref opts 'validate-reconfigure) - #:image-type (lookup-image-type-by-name - (assoc-ref opts 'image-type)) - #:image-size (assoc-ref opts 'image-size) - #:volatile-root? - (assoc-ref opts 'volatile-root?) #:full-boot? (assoc-ref opts 'full-boot?) #:container-shared-network? (assoc-ref opts 'container-shared-network?) @@ -1263,7 +1262,6 @@ resulting from command-line parsing." (_ #f)) opts) #:install-bootloader? bootloader? - #:label label #:target target-file #:bootloader-target bootloader-target #:gc-root (assoc-ref opts 'gc-root))))) diff --git a/tests/guix-system.sh b/tests/guix-system.sh index ddbdd0edcd..ce4030bc59 100644 --- a/tests/guix-system.sh +++ b/tests/guix-system.sh @@ -333,12 +333,11 @@ for example in gnu/system/examples/*.tmpl; do guix system -n disk-image $target "$example" done -# Verify that the disk image types can be built. +# Verify that the images can be built. guix system -n vm gnu/system/examples/vm-image.tmpl +guix system -n image gnu/system/images/pinebook-pro.scm guix system -n image -t qcow2 gnu/system/examples/vm-image.tmpl -# This invocation was taken care of in the loop above: -# guix system -n disk-image gnu/system/examples/bare-bones.tmpl -guix system -n disk-image -t iso9660 gnu/system/examples/bare-bones.tmpl +guix system -n image -t iso9660 gnu/system/examples/bare-bones.tmpl guix system -n docker-image gnu/system/examples/docker-image.tmpl # Verify that at least the raw image type is available. -- 2.29.2