From patchwork Thu Sep 26 10:09:06 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Herman Rimm X-Patchwork-Id: 31492 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 B9B3827BBE9; Thu, 26 Sep 2024 11:12:10 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-6.4 required=5.0 tests=BAYES_00,DKIM_INVALID, DKIM_SIGNED,MAILING_LIST_MULTI,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 CBB5B27BBEB for ; Thu, 26 Sep 2024 11:12:08 +0100 (BST) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1stlTJ-0002yU-4h; Thu, 26 Sep 2024 06:11:41 -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 1stlTH-0002xQ-Lv for guix-patches@gnu.org; Thu, 26 Sep 2024 06:11:39 -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 1stlTH-0007Ph-BQ for guix-patches@gnu.org; Thu, 26 Sep 2024 06:11:39 -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=IJShaDk+nVvCcgJhpUHmyt7BkJueute34U1DFCvRRVc=; b=Ug3BqQG+RweF8LqdpaC+ZdAShRjhU+0AXPe/32eDzrxmUfId0BlJJLhr72FcOYhTusP/H9OGolG6egbSqSHjUvqGkKxohaJgBDNUukphKSwrwSRyqaOUGkAEr2PqTNLaJSyUL4u3DkHCyE1U1GJjZqaIt5cv5T+cV8wIxDW1xRz8vqDKo69VlB78bCuUEb8G9LlqVRGtIocfyIzDey8ceT1zqG8EQV01acymE7H/NobZNQU/7Z6P92oVG/P4Sgx8YMIclyIIjPmmZf9qlydDD+R271SKO8QOowi7Jax1bg5z4RG5E+eodNLa7CznEBvUllpMWTA7Wovtgi9p2gXlZw==; Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1stlTi-0003Uz-9d; Thu, 26 Sep 2024 06:12:06 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#73202] [PATCH v3 09/14] gnu: bootloader: Add bootloader-configurations->gexp. Resent-From: Herman Rimm Original-Sender: "Debbugs-submit" Resent-CC: lilah@lunabee.space, guix-patches@gnu.org Resent-Date: Thu, 26 Sep 2024 10:12:06 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 73202 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 73202@debbugs.gnu.org Cc: Lilah Tascheter , Lilah Tascheter X-Debbugs-Original-Xcc: Lilah Tascheter Received: via spool by 73202-submit@debbugs.gnu.org id=B73202.172734550613310 (code B ref 73202); Thu, 26 Sep 2024 10:12:06 +0000 Received: (at 73202) by debbugs.gnu.org; 26 Sep 2024 10:11:46 +0000 Received: from localhost ([127.0.0.1]:55500 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1stlTN-0003SW-El for submit@debbugs.gnu.org; Thu, 26 Sep 2024 06:11:45 -0400 Received: from 81-205-150-117.fixed.kpn.net ([81.205.150.117]:39475 helo=email.rimm.ee) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1stlSz-0003PA-Jv for 73202@debbugs.gnu.org; Thu, 26 Sep 2024 06:11:23 -0400 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=rimm.ee; s=herman; t=1727345441; h=from:from:reply-to:subject:subject:date:date:message-id:message-id: to:to:cc:cc:mime-version:mime-version: content-transfer-encoding:content-transfer-encoding: in-reply-to:in-reply-to:references:references; bh=qBNIh/kScwIFDm4cVMybJISLgB15iFQHhIQqqC68N6I=; b=sLeo8E8sZ/0XupqHGNTwOgS9j4GP2M8oqJ68gB2baZjQ4u8xMSLZ/XFnHgOgIKI0sAfxqX gRM3hBTCs1gc+zYwIcSV1NxGJxuzCX9SUCeeXuWnusycxVupMvtVN2fz+HOBcSUAbjfXS4 jCZdolEzEsSkr7ov1mYsmhyL2RMGt6VPO+IRlnLBhtOx8UnmLb0zFQep+Vxv+4BsGMjvL9 x1ycxG6DD43br44DtfSYwJjueTDPngP54CCs3N4n9jFeHfaBLvHUBl1rnfE1hxTaJvcuz2 vD4GleQcslNuPQUK1fxWZunJAApE4QC3CJSfvJwCu9VL3c4o/cGh412Ldhwqew== Received: by 81-205-150-117.fixed.kpn.net (OpenSMTPD) with ESMTPSA id 03d74ee7 (TLSv1.3:TLS_CHACHA20_POLY1305_SHA256:256:NO); Thu, 26 Sep 2024 10:10:41 +0000 (UTC) Date: Thu, 26 Sep 2024 12:09:06 +0200 Message-ID: <2ce2a5d1b077a35dcfc95c707703f8c0a11bf3b2.1727345067.git.herman@rimm.ee> X-Mailer: git-send-email 2.45.2 In-Reply-To: <74c789e74594d538308d33633ed8540283dcde49.1727345067.git.herman@rimm.ee> References: <74c789e74594d538308d33633ed8540283dcde49.1727345067.git.herman@rimm.ee> 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: , Reply-to: Herman Rimm X-ACL-Warn: , Herman Rimm via Guix-patches X-Patchwork-Original-From: Herman Rimm via Guix-patches via From: Herman Rimm 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 From: Lilah Tascheter * gnu/bootloader.scm (bootloader)[default-targets]: Add field. (target-overrides, normalize, bootloader-configuration->gexp, bootloader-configurations->gexp): New procedures. Change-Id: I3654d160f7306bb45a78b82ea6b249ff4281f739 --- gnu/bootloader.scm | 108 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 108 insertions(+) diff --git a/gnu/bootloader.scm b/gnu/bootloader.scm index 0c24996205..c77de6f55e 100644 --- a/gnu/bootloader.scm +++ b/gnu/bootloader.scm @@ -67,6 +67,7 @@ (define-module (gnu bootloader) bootloader? bootloader-name bootloader-package + bootloader-default-targets bootloader-installer bootloader-disk-image-installer bootloader-configuration-file @@ -107,6 +108,8 @@ (define-module (gnu bootloader) bootloader-configuration-device-tree-support? bootloader-configuration-extra-initrd + bootloader-configuration->gexp + bootloader-configurations->gexp efi-bootloader-chain)) @@ -255,6 +258,7 @@ (define-record-type* bootloader? (name bootloader-name) (package bootloader-package) + (default-targets bootloader-default-targets (default '())) (installer bootloader-installer) (disk-image-installer bootloader-disk-image-installer (default #f)) @@ -498,6 +502,110 @@ (define (bootloader-configuration-targets config) ;; hence the default value of '(#f) rather than '(). (list #f))) + +;;; +;;; Bootloader installation paths. +;;; + +(define (target-overrides . layers) + (let* ((types (flat-map (cute map bootloader-target-type <>) layers)) + ;; TODO: use loop instead of fold for early termination. + (pred (lambda (type layer found) + (or found (get-target-of-type type layer)))) + (find (lambda (type) (fold (cute pred type <> <>) #f layers)))) + (filter identity (map find (delete-duplicates types))))) + +(define (normalize targets) + "Augments TARGETS with filesystem information at runtime, allowing +users to specify a lot less information. Puts TARGETS into a normal +form, where each path is fully specified up to a device offset." + (define (mass m) + `((,(mount-source m) . ,m) + (,(mount-point m) . ,m))) + + (define (accessible=> d f) + (and d (access? d R_OK) (f d))) + + (define (fixuuid target) + (match-record target (uuid file-system) + (let ((type (cond ((not file-system) 'dce) + ((member file-system '("vfat" "fat32")) 'fat) + ((string=? file-system "ntfs") 'ntfs) + ((string=? file-system "iso9660") 'iso9660) + (else 'dce)))) + (bootloader-target (inherit target) + (uuid (cond ((uuid? uuid) uuid) + ((bytevector? uuid) (bytevector->uuid uuid type)) + ((string? uuid) (string->uuid uuid type)) + (else #f))))))) + + (define (arborify target targets) + (let* ((up (lambda (t) (and t (parent-of t targets)))) + (proto (unfold target-base? identity up (up target) list)) + (chain (reverse (cons target proto)))) + (bootloader-target + (inherit target) + (offset (and=> (car chain) bootloader-target-type)) + (path (reduce pathcat #f (map bootloader-target-path (cdr chain))))))) + + (let ((amounts (delay (apply append (map mass (mounts)))))) + (define (assoc-mnt f) + (lambda (v) (and=> (assoc-ref (force amounts) v) f))) + + (define (scrape target) + (match-record target + (expected? path offset device label uuid file-system) + (if expected? target + (bootloader-target + (inherit target) + (device (or device + (false-if-exception + (or (and=> uuid find-partition-by-uuid) + (and=> label find-partition-by-label))) + (and path ((assoc-mnt mount-source) + (unfold-pathcat target targets))))) + (label (or label (accessible=> device read-partition-label))) + (uuid (or uuid (accessible=> device read-partition-uuid))) + (file-system (or file-system (and=> device (assoc-mnt mount-type)))) + (offset (and path offset)) + (path (or path (and=> device (assoc-mnt mount-point)))))))) + + (let ((mid (map (compose fixuuid scrape) targets))) + (map (cut arborify <> mid) mid)))) + +(define* (bootloader-configuration->gexp bootloader-config args #:key + (root-offset "/") (overrides '())) + "Returns a gexp to install BOOTLOADER-CONFIG to its targets, passing ARGS +to each installer alongside the additional #:bootloader-config keyword +arguments. Target OVERRIDES are applied and all path targets have ROOT-OFFSET +applied. The following keyword arguments are expected in ARGS: +@enumerate +@item current-boot-alternative +@item old-boot-alternatives +@item locale (from bootmeta) +@item store-directory-prefix (from bootmeta) +@item store-crypto-devices (from bootmeta) +@end enumerate" + (let* ((bootloader (bootloader-configuration-bootloader bootloader-config)) + (installer (bootloader-installer bootloader)) + (auto-targets (list (bootloader-target + (type 'root) + (path root-offset) + (offset #f)))) + (targets (target-overrides + overrides + (bootloader-configuration-targets bootloader-config) + auto-targets + (bootloader-default-targets bootloader))) + (conf (bootloader-configuration + (inherit bootloader-config) + (targets (normalize targets))))) + (apply installer #:bootloader-config conf args))) + +(define (bootloader-configurations->gexp bootloader-configs . rest) + (apply gbegin (filter-map (cut apply bootloader-configuration->gexp <> rest) + bootloader-configs))) + ;;; ;;; Bootloaders.