From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mp0 ([2001:41d0:2:4a6f::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by ms11 with LMTPS id KLF2GRVpCWAdfgAA0tVLHw (envelope-from ) for ; Thu, 21 Jan 2021 11:44:21 +0000 Received: from aspmx1.migadu.com ([2001:41d0:2:4a6f::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by mp0 with LMTPS id sHpHFRVpCWDASQAA1q6Kng (envelope-from ) for ; Thu, 21 Jan 2021 11:44:21 +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 A9124940483 for ; Thu, 21 Jan 2021 11:44:20 +0000 (UTC) Received: from localhost ([::1]:54682 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1l2YNv-0005so-MH for larch@yhetil.org; Thu, 21 Jan 2021 06:44:19 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]:56238) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1l2YNe-0005fG-HH for guix-patches@gnu.org; Thu, 21 Jan 2021 06:44:02 -0500 Received: from debbugs.gnu.org ([209.51.188.43]:45440) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1l2YNe-00072d-9p for guix-patches@gnu.org; Thu, 21 Jan 2021 06:44:02 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1l2YNe-0006nk-7t for guix-patches@gnu.org; Thu, 21 Jan 2021 06:44:02 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#46017] [PATCH 2/2] scripts: system: Accept records as input. Resent-From: Mathieu Othacehe Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Thu, 21 Jan 2021 11:44:02 +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.161122939826079 (code B ref 46017); Thu, 21 Jan 2021 11:44:02 +0000 Received: (at 46017) by debbugs.gnu.org; 21 Jan 2021 11:43:18 +0000 Received: from localhost ([127.0.0.1]:56985 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1l2YMw-0006mU-7x for submit@debbugs.gnu.org; Thu, 21 Jan 2021 06:43:18 -0500 Received: from eggs.gnu.org ([209.51.188.92]:34728) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1l2YMu-0006m8-N8 for 46017@debbugs.gnu.org; Thu, 21 Jan 2021 06:43:17 -0500 Received: from fencepost.gnu.org ([2001:470:142:3::e]:40679) by eggs.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1l2YMp-0006fb-GW for 46017@debbugs.gnu.org; Thu, 21 Jan 2021 06:43:11 -0500 Received: from [2a01:e0a:19b:d9a0:98b7:b002:9499:5e2c] (port=44470 helo=localhost.localdomain) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1l2YMo-0004Cp-AN; Thu, 21 Jan 2021 06:43:10 -0500 From: Mathieu Othacehe Date: Thu, 21 Jan 2021 12:43:00 +0100 Message-Id: <20210121114300.72835-2-othacehe@gnu.org> X-Mailer: git-send-email 2.29.2 In-Reply-To: <20210121114300.72835-1-othacehe@gnu.org> References: <20210121114300.72835-1-othacehe@gnu.org> 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: A9124940483 X-Spam-Score: 2.15 X-Migadu-Scanner: scn0.migadu.com X-TUID: KxZ524m/hVEj * guix/scripts/system.scm (system-derivation-for-action): Replace "os" argument by "image". Remove "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. --- 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 | 128 ++++++++++++++--------------- tests/guix-system.sh | 7 +- 6 files changed, 79 insertions(+), 68 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..ae904b3fd6 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -680,13 +680,14 @@ 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 + image-size 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))) (case action ((build init reconfigure) (operating-system-derivation os)) @@ -704,25 +705,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 +755,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 +763,14 @@ 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? + image-size 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. +the 'image' action. 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,8 @@ static checks." (check-initrd-modules os))) (mlet* %store-monad - ((sys (system-derivation-for-action os action - #:label label - #:image-type image-type + ((sys (system-derivation-for-action image action #:image-size image-size - #:volatile-root? volatile-root? #:full-boot? full-boot? #:container-shared-network? container-shared-network? #:mappings mappings)) @@ -1168,9 +1153,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 +1169,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 +1245,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 +1254,7 @@ 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 +1264,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