From patchwork Sun Oct 29 18:40:04 2023 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: David Elsing X-Patchwork-Id: 55569 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 10C0027BBEA; Sun, 29 Oct 2023 18:43:01 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.7 required=5.0 tests=BAYES_00,DKIM_INVALID, DKIM_SIGNED,MAILING_LIST_MULTI,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 C763727BBE9 for ; Sun, 29 Oct 2023 18:42:57 +0000 (GMT) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1qxAk4-0000yX-1v; Sun, 29 Oct 2023 14:42:32 -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 1qxAk2-0000yK-Gn for guix-patches@gnu.org; Sun, 29 Oct 2023 14:42:30 -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 1qxAk2-0007kS-8H for guix-patches@gnu.org; Sun, 29 Oct 2023 14:42:30 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1qxAkY-0007zF-JY for guix-patches@gnu.org; Sun, 29 Oct 2023 14:43:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#66824] [WIP PATCH] [WIP] Reference original packages in grafted packages. Resent-From: David Elsing Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Sun, 29 Oct 2023 18:43:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: report 66824 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 66824@debbugs.gnu.org Cc: David Elsing X-Debbugs-Original-To: guix-patches@gnu.org Received: via spool by submit@debbugs.gnu.org id=B.169860493230628 (code B ref -1); Sun, 29 Oct 2023 18:43:02 +0000 Received: (at submit) by debbugs.gnu.org; 29 Oct 2023 18:42:12 +0000 Received: from localhost ([127.0.0.1]:43338 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1qxAji-0007xv-Jm for submit@debbugs.gnu.org; Sun, 29 Oct 2023 14:42:11 -0400 Received: from lists.gnu.org ([2001:470:142::17]:45856) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1qxAjg-0007xf-IB for submit@debbugs.gnu.org; Sun, 29 Oct 2023 14:42:10 -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 1qxAj4-0000kk-BZ for guix-patches@gnu.org; Sun, 29 Oct 2023 14:41:30 -0400 Received: from mout01.posteo.de ([185.67.36.65]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1qxAiz-0007Xq-TL for guix-patches@gnu.org; Sun, 29 Oct 2023 14:41:29 -0400 Received: from submission (posteo.de [185.67.36.169]) by mout01.posteo.de (Postfix) with ESMTPS id 4EE8D240028 for ; Sun, 29 Oct 2023 19:41:22 +0100 (CET) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=posteo.net; s=2017; t=1698604882; bh=xIleqz7jaYdcaCu0NqaVQ1S7bo/acY5bSzXQO/baUu0=; h=From:To:Cc:Subject:Date:Message-ID:MIME-Version: Content-Transfer-Encoding:From; b=CIMqrcY6oAmMilbvUXDe2wb0Q+k4Iqtts7iOhGJithNsEXEW+pFnlt+R1R39Icz6h CfEzW8GUdBIm+wMgo6iCMRJ3IWNDUGnHLnCgTUkNxYJAkb6ex8NrXPphCfp5TQxSj5 538lovO2TYBah7BOFcT6ZkeZ+FgQAo5KTpDU/M+zu72rQJ0wwWArEFNDmpO5NXVsmB TRbg4s59pPhGxyr3R/mnkqNckFugzzxfZEVw5OQ6sL5eSvhxEl4xJasuZqzhvBOvlf iSbgHn/o6UQZxh8wRremQdkj/LVBmpjBoiMiGLoMwEESCMJpDnClBVViy/zuqKAUDg tcpc0UxNXRLeg== Received: from customer (localhost [127.0.0.1]) by submission (posteo.de) with ESMTPSA id 4SJQGT528cz9rxH; Sun, 29 Oct 2023 19:41:21 +0100 (CET) From: David Elsing Date: Sun, 29 Oct 2023 18:40:04 +0000 Message-ID: <20231029184113.13199-1-david.elsing@posteo.net> MIME-Version: 1.0 Received-SPF: pass client-ip=185.67.36.65; envelope-from=david.elsing@posteo.net; helo=mout01.posteo.de X-Spam_score_int: -53 X-Spam_score: -5.4 X-Spam_bar: ----- X-Spam_report: (-5.4 / 5.0 requ) BAYES_00=-1.9, DKIM_SIGNED=0.1, DKIM_VALID=-0.1, DKIM_VALID_AU=-0.1, DKIM_VALID_EF=-0.1, RCVD_IN_DNSWL_MED=-2.3, RCVD_IN_MSPIKE_H5=-1, RCVD_IN_MSPIKE_WL=-0.01, SPF_HELO_NONE=0.001, SPF_PASS=-0.001 autolearn=ham autolearn_force=no X-Spam_action: no action 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-bounces+patchwork=mira.cbaines.net@gnu.org X-getmail-retrieved-from-mailbox: Patches For a grafted package, a symbolic link is created to the ungrafted package in the .guix-grafts subdirectory. This is activated by default can be disabled by passing the --no-graft-reference-original option. --- This addresses https://issues.guix.gnu.org/54495. Would something like this be acceptable? In my opinion, it would make garbage collector roots much more useful in the presence of grafts. I named the symlink file by the store directory name of the grafted package itself to avoid collisions. Most of this patch consists of passing graft-reference-original? around in addition to graft?, I'm not sure of the name however. When graft? is #f, the derivations are the same regardless of graft-reference-original?, so it does not need to be set to #f in the --no-grafts case. guix/build/graft.scm | 22 +++++++++++++++++----- guix/gexp.scm | 26 ++++++++++++++++++++++---- guix/grafts.scm | 24 +++++++++++++++++------- guix/packages.scm | 13 ++++++++++--- guix/scripts.scm | 8 ++++++-- guix/scripts/archive.scm | 5 ++++- guix/scripts/build.scm | 22 ++++++++++++++++++++-- guix/scripts/environment.scm | 5 ++++- guix/scripts/home.scm | 5 ++++- guix/scripts/package.scm | 5 ++++- guix/scripts/pull.scm | 5 ++++- guix/scripts/shell.scm | 12 +++++++++--- guix/scripts/system.scm | 5 ++++- guix/store.scm | 18 ++++++++++++++++++ 14 files changed, 143 insertions(+), 32 deletions(-) diff --git a/guix/build/graft.scm b/guix/build/graft.scm index 281dbaba6f..83a7f20f76 100644 --- a/guix/build/graft.scm +++ b/guix/build/graft.scm @@ -340,7 +340,8 @@ (define not-slash (() #t)))) (define* (rewrite-directory directory output mapping - #:optional (store (%store-directory))) + #:optional (store (%store-directory)) + #:key (reference-original? #t)) "Copy DIRECTORY to OUTPUT, replacing strings according to MAPPING, a list of file name pairs." @@ -417,7 +418,14 @@ (define (rewrite-leaf file) (exit-on-exception rewrite-leaf) (find-files directory (const #t) #:directories? #t)) - (rename-matching-files output mapping)) + (rename-matching-files output mapping) + + (when reference-original? + ;; Create a symbolic link to the original directory + (mkdir-p* (string-append output "/.guix-grafts")) + (symlink directory + (string-append output "/.guix-grafts/" + (basename output))))) (define %graft-hooks ;; Default list of hooks run after grafting. @@ -425,14 +433,18 @@ (define %graft-hooks (define* (graft old-outputs new-outputs mapping #:key (log-port (current-output-port)) - (hooks %graft-hooks)) + (hooks %graft-hooks) + (reference-original? #t)) "Apply the grafts described by MAPPING on OLD-OUTPUTS, leading to NEW-OUTPUTS. MAPPING must be a list of file name pairs; OLD-OUTPUTS and -NEW-OUTPUTS are lists of output name/file name pairs." +NEW-OUTPUTS are lists of output name/file name pairs. If REFERENCE-ORIGINAL? +is #t, a symlink to the corresponding directory in NEW-OUTPUTS is added to +each directory in OLD-OUTPUTS." (for-each (lambda (input output) (format log-port "grafting '~a' -> '~a'...~%" input output) (force-output) - (rewrite-directory input output mapping)) + (rewrite-directory input output mapping + #:reference-original? reference-original?)) (match old-outputs (((names . files) ...) files)) diff --git a/guix/gexp.scm b/guix/gexp.scm index 0fe4f1c98a..6cf4da0cdc 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -286,7 +286,8 @@ (define* (lower-object obj (mlet %store-monad ((target (if (eq? target 'current) (current-target-system) (return target))) - (graft? (grafting?))) + (graft? (grafting?)) + (graft-reference-original? (graft-referencing-original?))) (let loop ((obj obj)) (match (lookup-compiler obj) (#f @@ -302,7 +303,8 @@ (define* (lower-object obj (loop lowered) (return lowered))) obj - system target graft?))))))) + system target graft? + graft-reference-original?))))))) (define* (lower+expand-object obj #:optional (system (%current-system)) @@ -317,11 +319,14 @@ (define* (lower+expand-object obj (raise (condition (&gexp-input-error (input obj))))) (lower (mlet* %store-monad ((graft? (grafting?)) + (graft-reference-original? + (graft-referencing-original?)) (lowered (if (derivation? obj) (return obj) (mcached (lower obj system target) - obj - system target graft?)))) + obj system target + graft? + graft-reference-original?)))) ;; LOWER might return something that needs to be further ;; lowered. (if (struct? lowered) @@ -1011,6 +1016,7 @@ (define* (lower-gexp exp (system (%current-system)) (target 'current) (graft? (%graft?)) + (graft-reference-original? (%graft-reference-original?)) (guile-for-build (%guile-for-build)) (effective-version "3.0") @@ -1047,6 +1053,8 @@ (define (search-path modules extensions suffix) ;; '%current-target-system' to be looked up at >>= ;; time. (graft? (set-grafting graft?)) + (graft-reference-original? + (set-graft-reference-original graft-reference-original?)) (system -> (or system (%current-system))) (target -> (if (eq? target 'current) @@ -1073,6 +1081,7 @@ (define (search-path modules extensions suffix) #:module-path module-path)) (modules -> (car modules+compiled)) (compiled -> (cdr modules+compiled))) + (define load-path (search-path modules exts (string-append "/share/guile/site/" effective-version))) @@ -1084,6 +1093,7 @@ (define load-compiled-path (mbegin %store-monad (set-grafting graft?) ;restore the initial setting + (set-graft-reference-original graft-reference-original?) (return (lowered-gexp sexp `(,@(if (derivation? modules) (list (derivation-input modules)) @@ -1108,6 +1118,8 @@ (define* (gexp->derivation name exp (guile-for-build (%guile-for-build)) (effective-version "3.0") (graft? (%graft?)) + (graft-reference-original? + (%graft-reference-original?)) references-graphs allowed-references disallowed-references leaked-env-vars @@ -1158,6 +1170,7 @@ (define* (gexp->derivation name exp The other arguments are as for 'derivation'." (define outputs (gexp-outputs exp)) (define requested-graft? graft?) + (define requested-graft-reference-original? graft-reference-original?) (define (graphs-file-names graphs) ;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS. @@ -1181,6 +1194,8 @@ (define (add-modules exp modules) ;; '%current-target-system' to be looked up at >>= ;; time. (graft? (set-grafting graft?)) + (graft-reference-original? + (set-graft-reference-original graft-reference-original?)) (system -> (or system (%current-system))) (target -> (if (eq? target 'current) @@ -1192,6 +1207,8 @@ (define (add-modules exp modules) #:system system #:target target #:graft? requested-graft? + #:graft-reference-original? + requested-graft-reference-original? #:guile-for-build guile-for-build #:effective-version @@ -1220,6 +1237,7 @@ (define (add-modules exp modules) (lowered-gexp-sexp lowered))))) (mbegin %store-monad (set-grafting graft?) ;restore the initial setting + (set-graft-reference-original graft-reference-original?) (raw-derivation name (string-append (derivation-input-output-path guile) "/bin/guile") diff --git a/guix/grafts.scm b/guix/grafts.scm index 48f4c212f7..c232fd509d 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -44,6 +44,7 @@ (define-module (guix grafts) %graft-with-utf8-locale?) #:re-export (%graft? ;for backward compatibility + %graft-reference-original? without-grafting set-grafting grafting?)) @@ -92,7 +93,8 @@ (define* (graft-derivation/shallow drv grafts (name (derivation-name drv)) (outputs (derivation-output-names drv)) (guile (%guile-for-build)) - (system (%current-system))) + (system (%current-system)) + (reference-original? #t)) "Return a derivation called NAME, which applies GRAFTS to the specified OUTPUTS of DRV. This procedure performs \"shallow\" grafting in that GRAFTS are not recursively applied to dependencies of DRV." @@ -144,7 +146,8 @@ (define %outputs (cons (assoc-ref old-outputs name) file))) %outputs)))) - (graft old-outputs %outputs mapping))))) + (graft old-outputs %outputs mapping + #:reference-original? #$reference-original?))))) (define properties @@ -246,7 +249,8 @@ (define* (cumulative-grafts store drv grafts #:key (outputs (derivation-output-names drv)) (guile (%guile-for-build)) - (system (%current-system))) + (system (%current-system)) + (reference-original? #t)) "Augment GRAFTS with additional grafts resulting from the application of GRAFTS to the dependencies of DRV. Return the resulting list of grafts. @@ -278,7 +282,9 @@ (define (dependency-grafts items) (cumulative-grafts store drv grafts #:outputs (list output) #:guile guile - #:system system))))) + #:system system + #:reference-original? + reference-original?))))) (reference-origins drv items))) (with-cache (list (derivation-file-name drv) outputs grafts) @@ -300,7 +306,9 @@ (define (dependency-grafts items) (let* ((new (graft-derivation/shallow* store drv applicable #:outputs outputs #:guile guile - #:system system)) + #:system system + #:reference-original? + reference-original?)) (grafts (append (map (lambda (output) (graft (origin drv) @@ -315,7 +323,8 @@ (define* (graft-derivation store drv grafts #:key (guile (%guile-for-build)) (outputs (derivation-output-names drv)) - (system (%current-system))) + (system (%current-system)) + (reference-original? #t)) "Apply GRAFTS to the OUTPUTS of DRV and all their dependencies, recursively. That is, if GRAFTS apply only indirectly to DRV, graft the dependencies of DRV, and graft DRV itself to refer to those grafted dependencies." @@ -323,7 +332,8 @@ (define* (graft-derivation store drv grafts (run-with-state (cumulative-grafts store drv grafts #:outputs outputs - #:guile guile #:system system) + #:guile guile #:system system + #:reference-original? reference-original?) (store-connection-cache store %graft-cache)))) ;; Save CACHE in STORE to benefit from it on the next call. diff --git a/guix/packages.scm b/guix/packages.scm index e2e82692ad..41dec95355 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -1962,7 +1962,10 @@ (define graft-derivation* (define* (package->derivation package #:optional (system (%current-system)) - #:key (graft? (%graft?))) + #:key + (graft? (%graft?)) + (graft-reference-original? + (%graft-reference-original?))) "Return the object of PACKAGE for SYSTEM." ;; Compute the derivation and cache the result. Caching is important @@ -1982,7 +1985,9 @@ (define* (package->derivation package system #:graft? #f))) (graft-derivation* drv grafts #:system system - #:guile guile))))) + #:guile guile + #:reference-original? + graft-reference-original?))))) (return drv))) package system #f graft?)) @@ -2005,7 +2010,9 @@ (define* (package->cross-derivation package target system #:graft? #f))) (graft-derivation* drv grafts #:system system - #:guile guile))))) + #:guile guile + #:reference-original? + graft-reference-original?))))) (return drv))) package system target graft?)) diff --git a/guix/scripts.scm b/guix/scripts.scm index 5d11ce7fe9..7f9e53b28f 100644 --- a/guix/scripts.scm +++ b/guix/scripts.scm @@ -197,13 +197,17 @@ (define* (build-package package #:rest build-options) "Build PACKAGE using BUILD-OPTIONS acceptable by 'set-build-options'. Show what and how will/would be built." - (mlet %store-monad ((grafting? ((lift0 %graft? %store-monad)))) + (mlet %store-monad ((grafting? ((lift0 %graft? %store-monad))) + (graft-reference-original? + ((lift0 %graft-reference-original? %store-monad)))) (apply set-build-options* #:use-substitutes? use-substitutes? (strip-keyword-arguments '(#:dry-run?) build-options)) (mlet %store-monad ((derivation (package->derivation package #:graft? (and (not dry-run?) - grafting?)))) + grafting?) + #:graft-reference-original? + graft-reference-original?))) (mbegin %store-monad (maybe-build (list derivation) #:use-substitutes? use-substitutes? diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 2b5a55a23f..34151d70b6 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -58,6 +58,7 @@ (define %default-options (substitutes? . #t) (offload? . #t) (graft? . #t) + (graft-reference-original? . #t) (print-build-trace? . #t) (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) @@ -377,7 +378,9 @@ (define (lines port) (with-error-handling (let ((opts (parse-command-line args %options (list %default-options)))) - (parameterize ((%graft? (assoc-ref opts 'graft?))) + (parameterize ((%graft? (assoc-ref opts 'graft?)) + (%graft-reference-original? + (assoc-ref opts 'graft-reference-original?))) (cond ((assoc-ref opts 'generate-key) => generate-key-pair) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 05f022a92e..c17d84bd20 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -170,6 +170,10 @@ (define (show-build-options-help) fetch substitute from URLS if they are authorized")) (display (G_ " --no-grafts do not graft packages")) + (display (G_ " + --no-graft-reference-original + for grafted packages, do not reference the ungrafted + version")) (display (G_ " --no-offload do not attempt to offload builds")) (display (G_ " @@ -290,6 +294,13 @@ (define %standard-build-options (alist-cons 'graft? #f (alist-delete 'graft? result eq?)) rest))) + (option '("no-graft-reference-original") #f #f + (lambda (opt name arg result . rest) + (apply values + (alist-cons + 'graft-reference-original? #f + (alist-delete 'graft-reference-original? result)) + rest))) (option '("no-offload" "no-build-hook") #f #f (lambda (opt name arg result . rest) (when (string=? name "no-build-hook") @@ -418,6 +429,7 @@ (define %default-options ;; Alist of default option values. `((build-mode . ,(build-mode normal)) (graft? . #t) + (graft-reference-original? . #t) (substitutes? . #t) (offload? . #t) (print-build-trace? . #t) @@ -633,6 +645,7 @@ (define package->derivation (define src (assoc-ref opts 'source)) (define graft? (assoc-ref opts 'graft?)) + (define graft-reference-original? (assoc-ref opts 'graft-reference-original?)) (define systems (match (filter-map (match-lambda (('system . system) system) @@ -707,7 +720,8 @@ (define (compute-derivation obj system) ;; of user packages. Since 'guix build' is the primary tool for people ;; testing new packages, report such errors gracefully. (with-unbound-variable-handling - (parameterize ((%graft? graft?)) + (parameterize ((%graft? graft?) + (%graft-reference-original? graft-reference-original?)) (append-map (lambda (system) (concatenate (map/accumulate-builds store @@ -740,6 +754,9 @@ (define opts (define graft? (assoc-ref opts 'graft?)) + (define graft-reference-original? + (assoc-ref opts 'graft-reference-original?)) + (with-error-handling (with-status-verbosity (assoc-ref opts 'verbosity) (with-store store @@ -757,7 +774,8 @@ (define graft? ;; Set grafting upfront in case the user's input ;; depends on it (e.g., a manifest or code snippet that ;; calls 'gexp->derivation'). - (%graft? graft?)) + (%graft? graft?) + (%graft-reference-original? graft-reference-original?)) (let* ((mode (assoc-ref opts 'build-mode)) (drv (options->derivations store opts)) (urls (map (cut string-append <> "/log") diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 6ae3b11e39..ef801522e4 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -171,6 +171,7 @@ (define %default-options (symlinks . ()) (offload? . #t) (graft? . #t) + (graft-reference-original? . #t) (print-build-trace? . #t) (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) @@ -1100,7 +1101,9 @@ (define-syntax-rule (with-store/maybe store exp ...) ;; Evaluate EXP... with STORE bound to a connection, unless ;; STORE-NEEDED? is false, in which case STORE is bound to #f. (let ((proc (lambda (store) exp ...))) - (parameterize ((%graft? (assoc-ref opts 'graft?))) + (parameterize ((%graft? (assoc-ref opts 'graft?)) + (%graft-reference-original? + (assoc-ref opts 'graft-reference-original?))) (if store-needed? (with-store s (set-build-options-from-command-line s opts) diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm index b4c82d275f..8f47c7ab73 100644 --- a/guix/scripts/home.scm +++ b/guix/scripts/home.scm @@ -211,6 +211,7 @@ (define %options (define %default-options `((graft? . #t) + (graft-reference-original? . #t) (substitutes? . #t) (offload? . #t) (print-build-trace? . #t) @@ -694,7 +695,9 @@ (define (parse-args args) (let* ((opts (parse-args args)) (args (option-arguments opts)) (command (assoc-ref opts 'action))) - (parameterize ((%graft? (assoc-ref opts 'graft?))) + (parameterize ((%graft? (assoc-ref opts 'graft?)) + (%graft-reference-original? + (assoc-ref opts 'graft-reference-original?))) (with-status-verbosity (verbosity-level opts) (process-command command args opts)))))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index a489e06e73..d998b5c695 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -419,6 +419,7 @@ (define %default-options `((verbosity . 1) (debug . 0) (graft? . #t) + (graft-reference-original? . #t) (substitutes? . #t) (offload? . #t) (print-build-trace? . #t) @@ -1084,7 +1085,9 @@ (define (guix-package* opts) (with-error-handling (or (process-query opts) (parameterize ((%store (open-connection)) - (%graft? (assoc-ref opts 'graft?))) + (%graft? (assoc-ref opts 'graft?)) + (%graft-reference-original? + (assoc-ref opts 'graft-reference-original?))) (with-status-verbosity (assoc-ref opts 'verbosity) (set-build-options-from-command-line (%store) opts) (with-build-handler (build-notifier #:use-substitutes? diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 58d3cd7e83..f1f1702d18 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -74,6 +74,7 @@ (define %default-options (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) (graft? . #t) + (graft-reference-original? . #t) (debug . 0) (verbosity . 1) (authenticate-channels? . #t) @@ -859,7 +860,9 @@ (define (no-arguments arg _) (with-store store (with-status-verbosity (assoc-ref opts 'verbosity) (parameterize ((%current-system (assoc-ref opts 'system)) - (%graft? (assoc-ref opts 'graft?))) + (%graft? (assoc-ref opts 'graft?)) + (%graft-reference-original? + (assoc-ref opts 'graft-reference-original?))) (with-build-handler (build-notifier #:use-substitutes? substitutes? #:verbosity diff --git a/guix/scripts/shell.scm b/guix/scripts/shell.scm index 10ea110fee..afa9eee48f 100644 --- a/guix/scripts/shell.scm +++ b/guix/scripts/shell.scm @@ -26,7 +26,7 @@ (define-module (guix scripts shell) #:autoload (guix transformations) (options->transformation transformation-option-key? show-transformation-options-help) - #:autoload (guix grafts) (%graft?) + #:autoload (guix grafts) (%graft? %graft-reference-original?) #:use-module (guix scripts) #:use-module (guix packages) #:use-module (guix profiles) @@ -355,7 +355,10 @@ (define (profile-file-cache-key file system) ;; be insufficient: . (sha256 (string->utf8 (string-append primary-key ":" system ":" - (if (%graft?) "" "ungrafted:") + (if (%graft?) + (if (%graft-reference-original?) + "" "noreforig:") + "ungrafted:") (number->string (stat:dev stat)) ":" (number->string (stat:ino stat)))))))))) @@ -368,7 +371,10 @@ (define (profile-spec-cache-key specs system) (bytevector->base32-string (sha256 (string->utf8 (string-append primary-key ":" system ":" - (if (%graft?) "" "ungrafted:") + (if (%graft?) + (if (%graft-reference-original?) + "" "noreforig:") + "ungrafted:") (object->string specs)))))))) (define (profile-cached-gc-root opts) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index f85b663d64..308dbaf813 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -1166,6 +1166,7 @@ (define %default-options (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) (graft? . #t) + (graft-reference-original? . #t) (debug . 0) (verbosity . #f) ;default (validate-reconfigure . ,ensure-forward-reconfigure) @@ -1456,7 +1457,9 @@ (define (fail) parse-sub-command)) (args (option-arguments opts)) (command (assoc-ref opts 'action))) - (parameterize ((%graft? (assoc-ref opts 'graft?))) + (parameterize ((%graft? (assoc-ref opts 'graft?)) + (%graft-reference-original? + (assoc-ref opts 'graft-reference-original?))) (with-status-verbosity (verbosity-level opts) (process-command command args opts)))))) diff --git a/guix/store.scm b/guix/store.scm index f8e77b2cd9..ba5a5dd3f2 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -181,9 +181,12 @@ (define-module (guix store) interned-file-tree %graft? + %graft-reference-original? without-grafting set-grafting + set-graft-reference-original grafting? + graft-referencing-original? %store-prefix store-path @@ -2183,6 +2186,9 @@ (define %graft? ;; Whether to honor package grafts by default. (make-parameter #t)) +(define %graft-reference-original? + (make-parameter #t)) + (define (call-without-grafting thunk) (lambda (store) (values (parameterize ((%graft? #f)) @@ -2200,11 +2206,23 @@ (define-inlinable (set-grafting enable?) (lambda (store) (values (%graft? enable?) store))) +(define-inlinable (set-graft-reference-original enable?) + ;; This monadic procedure enables grafting when ENABLE? is true, and + ;; disables it otherwise. It returns the previous setting. + (lambda (store) + (values (%graft-reference-original? enable?) store))) + (define-inlinable (grafting?) ;; Return a Boolean indicating whether grafting is enabled. (lambda (store) (values (%graft?) store))) +(define-inlinable (graft-referencing-original?) + ;; Return a Boolean indicating whether grafted packages should contain a + ;; symlink to the corresponding ungrafted package. + (lambda (store) + (values (%graft-reference-original?) store))) + ;;; ;;; Store paths.