From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mp1.migadu.com ([2001:41d0:403:4876::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by ms13.migadu.com with LMTPS id SH3OB8OOsWZAJQAA62LTzQ:P1 (envelope-from ) for ; Tue, 06 Aug 2024 02:47:31 +0000 Received: from aspmx1.migadu.com ([2001:41d0:403:4876::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by mp1.migadu.com with LMTPS id SH3OB8OOsWZAJQAA62LTzQ (envelope-from ) for ; Tue, 06 Aug 2024 04:47:31 +0200 X-Envelope-To: larch@yhetil.org Authentication-Results: aspmx1.migadu.com; dkim=fail ("headers rsa verify failed") header.d=debbugs.gnu.org header.s=debbugs-gnu-org header.b="V/e6SU3R"; dkim=fail ("headers rsa verify failed") header.d=lunabee.space header.s=purelymail3 header.b=cdXUZNpA; dkim=fail ("headers rsa verify failed") header.d=purelymail.com header.s=purelymail3 header.b=NUDoOSYU; spf=pass (aspmx1.migadu.com: domain of "guix-patches-bounces+larch=yhetil.org@gnu.org" designates 209.51.188.17 as permitted sender) smtp.mailfrom="guix-patches-bounces+larch=yhetil.org@gnu.org"; dmarc=pass (policy=none) header.from=gnu.org ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=yhetil.org; s=key1; t=1722912451; h=from:from:sender:sender:reply-to:reply-to:subject:subject:date:date: message-id:message-id:to:to:cc:cc:mime-version:mime-version: content-type:content-type: content-transfer-encoding:content-transfer-encoding:resent-cc: resent-from:resent-sender:resent-message-id:in-reply-to:in-reply-to: references:references:list-id:list-help:list-unsubscribe: list-subscribe:list-post:dkim-signature; bh=GjrXfij5RX9qb7IHSScxv59yMM33C8u3PeXsgfI8yFM=; b=RfO+tbP3yHbZNo9R4qECZB8cODSEhjj5mV+cOT9N7g7w1nHkb+WCha1XoT501o8ZiQ1TFY yT20LSeIbw5/evO5Xxlyi2BELa0PjCYrnhlZrwSP+Z//vXgAKT/do5lfCERTrYQhu4Td9H lwTMbIT2FcEevpulUqkoE0zh+qVYKIQzPOpach3x7/7sAjVMQQSTSX7DmKYgAdzJ4369vo zGCHgq0W/Mue+eUEc8ZE2uRIPID4cQFzDrh/Fog+I7/0TZMblCvM+JoFKwt6ru9/q+1uZ9 2/OamB3FRNHxy7Y5OJoJrW8UaNovFRQs/T85HE5Fh4m9pXROn1Ia/wtGdPCn2Q== ARC-Authentication-Results: i=1; aspmx1.migadu.com; dkim=fail ("headers rsa verify failed") header.d=debbugs.gnu.org header.s=debbugs-gnu-org header.b="V/e6SU3R"; dkim=fail ("headers rsa verify failed") header.d=lunabee.space header.s=purelymail3 header.b=cdXUZNpA; dkim=fail ("headers rsa verify failed") header.d=purelymail.com header.s=purelymail3 header.b=NUDoOSYU; spf=pass (aspmx1.migadu.com: domain of "guix-patches-bounces+larch=yhetil.org@gnu.org" designates 209.51.188.17 as permitted sender) smtp.mailfrom="guix-patches-bounces+larch=yhetil.org@gnu.org"; dmarc=pass (policy=none) header.from=gnu.org ARC-Seal: i=1; s=key1; d=yhetil.org; t=1722912451; a=rsa-sha256; cv=none; b=rDldzOb9O5Pz5+8zzaSjnQGjRnI5uKahAy7Bs7sUTqPvP0GNyJ1IMlyD4z2lod0nstanUK h8HzV9nK5Xi6BPZKeGiwh7bNwL/d8frws2nXfsuGUq0xBD0yqLhf5q0Z6URLfItF9uM4iw TPfbR77a/zOWgpxYi+Ms2lzj1JQiHMFJKwBfPVY7blbnUiKPjmQhenWeqoPRj/0VwVABvC v8CzYD5zkZZeo8F+jl+7Xd5VEVkuAVdOw3+cki0hrObx4Bl3MkSP1m//Lo/ylUF+7LPs7H KIgsI5Xa4zZwkG4QDlhKz/xzozfta4DITLUaHqUDthakf1ppLWuV3M0WmECO9A== 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 E7A1B26BE8 for ; Tue, 6 Aug 2024 04:47:30 +0200 (CEST) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1sbADx-0000uF-2P; Mon, 05 Aug 2024 22:46:57 -0400 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 1sbADr-0000ry-02 for guix-patches@gnu.org; Mon, 05 Aug 2024 22:46:51 -0400 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 1sbADk-0001I9-Gm; Mon, 05 Aug 2024 22:46:49 -0400 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=GjrXfij5RX9qb7IHSScxv59yMM33C8u3PeXsgfI8yFM=; b=V/e6SU3RzQPsYy28BVH1Dk3ZpNFW7mZu0lk3M+0Xc+XjPsviyMzlwQRjHa3eiydHpK9IbBE9mEqG5LHGac+CBKcCuNPiFYUW4zWtn2iIbO/wnFL0biEXL5Sa1CZDGu11eVRCFl/t8kyncXgYjbDwluxTWBdHlEsUeOQMktjuUpU2PUUqQfZwQR7eZnYQHaOMuXtUc1rjA6wJ5XPjrSpiU3/LKWn1iKkefe+hiaraKFihFNuKahOPqjtLspG0+SCShKYKoyu4F0Hlpk07x7IT60Ika/SS9ywFIQVAqfT4GrngEAWtAggz7/kNo07HhaZfOQJFAFjNfVg/bv0sy8HkNw==; Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1sbAE4-0008Ud-K0; Mon, 05 Aug 2024 22:47:04 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#72457] [PATCH v4 02/15] gnu: Add bootloader target infastructure. Resent-From: Lilah Tascheter Original-Sender: "Debbugs-submit" Resent-CC: guix@cbaines.net, dev@jpoiret.xyz, lilah@lunabee.space, ludo@gnu.org, othacehe@gnu.org, zimon.toutoune@gmail.com, me@tobias.gr, guix-patches@gnu.org Resent-Date: Tue, 06 Aug 2024 02:47:04 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 72457 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 72457@debbugs.gnu.org Cc: Lilah Tascheter , Sergey Trofimov , Christopher Baines , Josselin Poiret , Lilah Tascheter , Ludovic Court??s , Mathieu Othacehe , Simon Tournier , Tobias Geerinckx-Rice X-Debbugs-Original-Xcc: Christopher Baines , Josselin Poiret , Lilah Tascheter , Ludovic Court??s , Mathieu Othacehe , Simon Tournier , Tobias Geerinckx-Rice Received: via spool by 72457-submit@debbugs.gnu.org id=B72457.172291239032381 (code B ref 72457); Tue, 06 Aug 2024 02:47:04 +0000 Received: (at 72457) by debbugs.gnu.org; 6 Aug 2024 02:46:30 +0000 Received: from localhost ([127.0.0.1]:59657 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1sbADV-0008Q4-35 for submit@debbugs.gnu.org; Mon, 05 Aug 2024 22:46:30 -0400 Received: from sendmail.purelymail.com ([34.202.193.197]:38542) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1sbADS-0008P4-5k for 72457@debbugs.gnu.org; Mon, 05 Aug 2024 22:46:27 -0400 DKIM-Signature: a=rsa-sha256; b=cdXUZNpAd93unboZNw7lwpqcjE/BeY2EG9IVRciy073QKN42XsaPkZytXEhYn4Ot3Kz/viaWAVU5bCrGVN5Oqa/17O0A/TKssj7gNmTKnJubV719tD9AhRgW9dUY9p6E+E8gjTaDuqebOyXBg5NS94TdSJBkxqEARW5HXws3+by0YQSguL9WX95jPglwEg24X0tjgga8pIB6VZRpykq5xGblqfNezoYPYgXXAsGNOXJzeTUSUVolcYvXF51qtlyVtsnHae87HIRhxgkiDP1VmoYQXyVPt9HVzBlV/KBdl0Bv0uewgg7xXW1BDCtSEaKN/6wKnGgp6scYUMKpEByx9Q==; s=purelymail3; d=lunabee.space; v=1; bh=HX1nYy/zwZ3IawonY9iRlGbuoXA36lvt5DMOH9H7gl4=; h=Received:From:To:Subject:Date; DKIM-Signature: a=rsa-sha256; b=NUDoOSYURXqQ9SJNCX7RGPlcTXZbDdxN8XMqTBoq1sv39YR7JunUs97inmFTGre7j4UzRrO3+TJF3cIy6LH4XEh/UTbFM10qINULToP3unVS3ip8/gGUpgkV/aqFfRRTacgvmNgmuBOhZoV7orUlp4wlpbHrbVYiYqXdMEnZ2q1WodWN0h11lvPQ+VnbTEcqzm0GHyf9BstpBw7Jdf+YZNm13XFoqvX3fmGlhUDOpcN3A+RF5qPUDdiPkdi6oSF7RNc5GQUXGyzfL9daMlaAXiQe+TSbA1kQGXI9SGuq3uYaUEKbFlF9cX80jN2vKAJgH9mWwo2IoatjPulVwpz3Ng==; s=purelymail3; d=purelymail.com; v=1; bh=HX1nYy/zwZ3IawonY9iRlGbuoXA36lvt5DMOH9H7gl4=; h=Feedback-ID:Received:From:To:Subject:Date; Feedback-ID: 8937:2070:null:purelymail X-Pm-Original-To: 72457@debbugs.gnu.org Received: by smtp.purelymail.com (Purelymail SMTP) with ESMTPSA id 1040940465; (version=TLSv1.3 cipher=TLS_AES_256_GCM_SHA384); Tue, 06 Aug 2024 02:45:47 +0000 (UTC) Date: Mon, 5 Aug 2024 21:44:40 -0500 Message-ID: In-Reply-To: References: MIME-Version: 1.0 Content-Transfer-Encoding: quoted-printable X-MIME-Autoconverted: from 8bit to quoted-printable by Purelymail Content-Type: text/plain; charset=UTF-8 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: , From: Lilah Tascheter via Guix-patches Reply-To: Lilah Tascheter Errors-To: guix-patches-bounces+larch=yhetil.org@gnu.org Sender: guix-patches-bounces+larch=yhetil.org@gnu.org X-Migadu-Country: US X-Migadu-Flow: FLOW_IN X-Spam-Score: -5.44 X-Migadu-Queue-Id: E7A1B26BE8 X-Migadu-Scanner: mx10.migadu.com X-Migadu-Spam-Score: -5.44 X-TUID: hOuejmMJOfQS * gnu/bootloader.scm (bootloader-target): New record. (&target-error): New condition. (pathcat, get-target-of-type, parent-of, unfold-pathcat, target-base?, type-major?, ensure, ensure-target-types, ensure-majors, gbegin): New procedures. (define-literal, with-targets, :path, :devpath, :device, :fs, :label, :uuid): New macros. (bootloader-modules): Prevent mutual imports. * guix/ui.scm (call-with-error-handling)[target-error?]: Handle target-errors. Change-Id: I3f07c9096dd8b91c04449b6360b3b7d21640da14 --- gnu/bootloader.scm | 212 ++++++++++++++++++++++++++++++++++++++++++++- guix/ui.scm | 8 ++ 2 files changed, 217 insertions(+), 3 deletions(-) diff --git a/gnu/bootloader.scm b/gnu/bootloader.scm index f32e90e79d..3ddc112cc6 100644 --- a/gnu/bootloader.scm +++ b/gnu/bootloader.scm @@ -31,10 +31,11 @@ (define-module (gnu bootloader) #:use-module (guix profiles) #:use-module (guix records) #:use-module (guix deprecation) - #:use-module ((guix ui) #:select (warn-about-load-error)) #:use-module (guix diagnostics) #:use-module (guix i18n) + #:use-module (guix modules) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (ice-9 match) @@ -63,6 +64,26 @@ (define-module (gnu bootloader) bootloader-configuration-file bootloader-configuration-file-generator =20 + + bootloader-target + bootloader-target? + bootloader-target-type + bootloader-target-expected? + bootloader-target-path + bootloader-target-offset + bootloader-target-device + bootloader-target-file-system + bootloader-target-label + bootloader-target-uuid + + target-error? + target-error-type + target-error-targets + + gbegin + :path :devpath :device :fs :label :uuid + with-targets + bootloader-configuration bootloader-configuration? bootloader-configuration-bootloader @@ -236,6 +257,191 @@ (define-record-type* (configuration-file bootloader-configuration-file) (configuration-file-generator bootloader-configuration-file-generator= )) =20 +=0C +;;; +;;; Bootloader target record. +;;; + +;; represents different kinds of targets in a normaliz= ed form. + +(define-record-type* + bootloader-target make-bootloader-target bootloader-target? + (type bootloader-target-type) ; symbol + (expected? bootloader-target-expected? (default #f)) ; bool + + (path bootloader-target-path (default #f)) ; string|#f + (offset bootloader-target-offset (thunked) ; symbol|#f + (default (and (bootloader-target-path this-record) + (not (eq? (bootloader-target-type this-record) 'ro= ot)) + 'root))) + (device bootloader-target-device (default #f)) ; string|#f + (file-system bootloader-target-file-system (default #f)) ; string|#f + (label bootloader-target-label (default #f)) ; string|#f + (uuid bootloader-target-uuid (default #f))) ; uuid|#f + +(define-condition-type &target-error &error target-error? + (type target-error-type) + (targets target-error-targets)) + +(define (pathcat p1 p2) + (string-append (string-trim-right p1 #\/) "/" (string-trim p2 #\/))) + +(define* (get-target-of-type type targets #:optional (require? #f)) + "Finds a target in TARGETS of type TYPE, optionally providing an error w= hen +not found if REQUIRE? is provided." + (let* ((pred (lambda (target) (eq? type (bootloader-target-type target))= )) + (candidates (filter pred targets)) + (ret (if (pair? candidates) (car candidates) #f))) + (if (and require? (not ret)) + (raise (condition + (&message (message (G_ "required, but not provided"))) + (&target-error (type type) (targets targets)))) + ret))) + +(define (parent-of target targets) + (and=3D> (bootloader-target-offset target) + (cut get-target-of-type <> targets #t))) + +(define (unfold-pathcat target targets) + (let ((quit (lambda (t) (not (and=3D> t bootloader-target-path))))) + (reduce pathcat #f + (unfold quit bootloader-target-path (cut parent-of <> targets) targe= t)))) + +(define (target-base? t) + (or (not t) (match-record t + (expected? offset device label uuid) + (or device label uuid (not offset) expected?)))) + +(define (type-major? target) (memq target '(root esp disk))) + +(define (ensure types targets end) + (let* ((used-in (cute unfold end identity (cut parent-of <> targets) <>)= ) + (cons-in (lambda (t) (cons t (used-in t)))) + (ensure (map (cut get-target-of-type <> targets #t) types))) + (filter ->bool (apply append (map cons-in ensure))))) + +(define* (ensure-target-types types targets #:optional (base? #f)) + "Ensures all TYPES are provided in TARGETS. Returns #t iff every ensure= d +target and its requirements are fully provided. Errors out when a require= d TYPE +isn't provided. When BASE?, only ensure path requirements up to a device.= " + (not (any bootloader-target-expected? + (ensure types targets (if base? target-base? not))))) + +(define (ensure-majors types targets) + "Errors out when a required TYPE isn't provided, or when use of multiple= major +targets is detected." + (let* ((all (map bootloader-target-type (ensure types targets target-bas= e?))) + (majors (delete-duplicates (filter type-major? all) eq?))) + (if (< (length majors) 2) #t + (raise (condition (&message (message (G_ "multiple major targets use= d"))) + (&target-error (type majors) (targets targets)))))= )) + + + +(define (gbegin . gex) + "Sequence provided g-expressions." + (case (length gex) ((0) #f) ((1) (car gex)) (else #~(begin #$@gex)))) + +;; syntax matching on free literals breaks easily, so bind them +(define-syntax-rule (define-literal id) (define-syntax id (syntax-rules ()= ))) +(define-literal :path) +(define-literal :devpath) +(define-literal :device) +(define-literal :fs) +(define-literal :label) +(define-literal :uuid) + +(define-syntax with-targets + (cut syntax-case <> () + ((_ targets-expr block ...) + (let* ((genvars (compose generate-temporaries iota)) + (targets (car (genvars 1))) + + (path? (cut syntax-case <> (:path) ((_ :path) #t) (_ #f))) + (qualified? (cut syntax-case <> (=3D>) + ((_ =3D> spec ...) (any path? #'(spec ...))) + (_ #f))) + + (resolve + (lambda (in target base) + (with-syntax ((target target) (base base) (targets targets= )) + (syntax-case in + (:path :devpath :device :fs :label :uuid) + ((name _) (not (identifier? #'name)) + #`(_ (syntax-error "binds must be to identifiers" #,i= n))) + ((name :device) #'(name (bootloader-target-device base= ))) + ((name :label) #'(name (bootloader-target-label base))= ) + ((name :uuid) #'(name (bootloader-target-uuid base))) + ((name :fs) #'(name (bootloader-target-file-system bas= e))) + ((name :path) #'(name (unfold-pathcat target targets))= ) + ((name :devpath) + #'(name (pathcat "/" (bootloader-target-path target))= )) + (_ #`(_ (syntax-error "invalid binding spec" #,in)))))= )) + (binds + (lambda (spec) + (syntax-case spec (=3D>) + ((type =3D> binds ...) + (with-syntax (((target base) (genvars 2)) (targets targ= ets)) + (append + #`((get (lambda (t) (get-target-of-type t targets #= t))) + (target (get type)) + (base (if (target-base? target) target + (get (bootloader-target-offset target)))= )) + (map (cut resolve <> #'target #'base) #'(binds ...)= )))) + (_ #f)))) + + (blocks + (cut syntax-case <> () + ((spec ... expr) + (let* ((specs #'(spec ...)) + (lets (apply append (filter-map binds specs))) + (type (cut syntax-case <> (=3D>) + ((t =3D> _ ...) #'t) (t #'t)))) + (receive (full part) (partition qualified? specs) + #`(and (ensure-majors (list #,@(map type specs)) #,ta= rgets) + (ensure-target-types (list #,@(map type part)) + #,targets #t) + (ensure-target-types (list #,@(map type full)) + #,targets #f) + (let* #,lets expr))))) + (bad #'(syntax-error "malformed block" bad))))) + "Using the list TARGETS, evaluate and sequence each BLOCK to produc= e a +gexp. BLOCK is a set of SPECs followed by an EXPR (evaluating to a gexp). = Each +SPEC denotes a type of target to guard EXPR on their existance and +full-qualification. This procedure is linear in regards to BLOCKs. + +SPEC may be of the following forms: +@itemize +@item 'TYPE Requires TYPE to be fully present or promised. Errors otherwis= e. +@item ('TYPE =3D> (VAR COMPONENT) ...): As type, but also binds variables.= TYPE's + COMPONENT is bound to the variable VAR as described below. +@end itemize + +Available COMPONENTs are: +@itemize +@item :path (fully-qualified) +@item :devpath (relative from device) +@item :device (auto-detected from uuid and label if not user-provided) +@item :fs +@item :label +@item :uuid +@end itemize + +Note that installers may be called multiple times with different targets b= eing +fully-qualified. To ensure that targets aren't installed multiple times, = make sure +that each BLOCK ensures at least one major target, either directly or indi= rectly. +Corrolarily, at most one major target should be ensured per BLOCK, under t= he same +conditions. Major targets originate from disk image handling, and are curr= ently: +@itemize +@item disk +@item root +@item esp +@end itemize" + #`(let ((#,targets targets-expr)) + (apply gbegin (filter ->bool + (list #,@(map blocks #'(block ...)))))))) + (bad #'(syntax-error "must provide targets" bad)))) + =0C ;;; ;;; Bootloader configuration record. @@ -305,10 +511,10 @@ (define (bootloader-configuration-targets config) =20 (define (bootloader-modules) "Return the list of bootloader modules." + ;; don't provide #:warn to prevent mutual imports (all-modules (map (lambda (entry) `(,entry . "gnu/bootloader")) - %load-path) - #:warn warn-about-load-error)) + %load-path))) =20 (define %bootloaders ;; The list of publically-known bootloaders. diff --git a/guix/ui.scm b/guix/ui.scm index 9db6f6e9d7..1c9300c9eb 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -36,6 +36,8 @@ ;;; along with GNU Guix. If not, see . =20 (define-module (guix ui) + #:use-module ((gnu bootloader) + #:select (target-error? target-error-type target-error-tar= gets)) #:use-module (guix i18n) #:use-module (guix colors) #:use-module (guix diagnostics) @@ -857,6 +859,12 @@ (define (call-with-error-handling thunk) (invoke-error-stop-signal c) (cons (invoke-error-program c) (invoke-error-arguments c)))) + ((target-error? c) + (leave (G_ "bootloader-target '~a'~@[: ~a~] ~ + among the following targets:~%~{~y~}") + (target-error-type c) + (and (message-condition? c) (condition-message c)) + (target-error-targets c))) =20 ((formatted-message? c) (apply report-error --=20 2.45.2