@@ -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))
@@ -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")
@@ -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.
@@ -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 <derivation> 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?))
@@ -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?
@@ -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)
@@ -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")
@@ -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)
@@ -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))))))
@@ -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?
@@ -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
@@ -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: <https://lwn.net/Articles/866582/>.
(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)
@@ -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))))))
@@ -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.