1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
4 ;;; This file is part of GNU Guix.
6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
7 ;;; under the terms of the GNU General Public License as published by
8 ;;; the Free Software Foundation; either version 3 of the License, or (at
9 ;;; your option) any later version.
11 ;;; GNU Guix is distributed in the hope that it will be useful, but
12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;;; GNU General Public License for more details.
16 ;;; You should have received a copy of the GNU General Public License
17 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
19 (define-module (guix transformations)
20 #:use-module (guix i18n)
21 #:use-module (guix store)
22 #:use-module (guix packages)
23 #:use-module (guix profiles)
24 #:use-module (guix diagnostics)
25 #:autoload (guix download) (download-to-store)
26 #:autoload (guix git-download) (git-reference? git-reference-url)
27 #:autoload (guix git) (git-checkout git-checkout? git-checkout-url)
28 #:autoload (guix upstream) (package-latest-release*
29 upstream-source-version
30 upstream-source-signature-urls)
31 #:use-module (guix utils)
32 #:use-module (guix memoization)
33 #:use-module (guix gexp)
35 ;; Use the procedure that destructures "NAME-VERSION" forms.
36 #:use-module ((guix build utils)
37 #:select ((package-name->name+version
38 . hyphen-package-name->name+version)))
40 #:use-module (srfi srfi-1)
41 #:use-module (srfi srfi-9)
42 #:use-module (srfi srfi-11)
43 #:use-module (srfi srfi-26)
44 #:use-module (srfi srfi-34)
45 #:use-module (srfi srfi-37)
46 #:use-module (ice-9 match)
47 #:use-module (ice-9 vlist)
48 #:export (options->transformation
49 manifest-entry-with-transformations
51 show-transformation-options-help
52 %transformation-options))
56 ;;; This module implements "package transformation options"---tools for
57 ;;; package graph rewriting. It contains the graph rewriting logic, but also
58 ;;; the tip of its user interface: command-line option handling.
62 (module-autoload! (current-module) '(gnu packages)
63 '(specification->package))
65 (define (numeric-extension? file-name)
66 "Return true if FILE-NAME ends with digits."
67 (string-every char-set:hex-digit (file-extension file-name)))
69 (define (tarball-base-name file-name)
70 "Return the \"base\" of FILE-NAME, removing '.tar.gz' or similar
73 (cond ((not (file-extension file-name))
75 ((numeric-extension? file-name)
77 ((string=? (file-extension file-name) "tar")
78 (file-sans-extension file-name))
79 ((file-extension file-name)
83 (_ (tarball-base-name (file-sans-extension file-name)))))
88 ;; Files to be downloaded.
89 (define-record-type <downloaded-file>
90 (downloaded-file uri recursive?)
92 (uri downloaded-file-uri)
93 (recursive? downloaded-file-recursive?))
95 (define download-to-store*
96 (store-lift download-to-store))
98 (define-gexp-compiler (compile-downloaded-file (file <downloaded-file>)
100 "Download FILE and return the result as a store item."
102 (($ <downloaded-file> uri recursive?)
103 (download-to-store* uri #:recursive? recursive?))))
105 (define* (package-with-source p uri #:optional version)
106 "Return a package based on P but with its source taken from URI. Extract
107 the new package's version number from URI."
108 (let ((base (tarball-base-name (basename uri))))
109 (let-values (((_ version*)
110 (hyphen-package-name->name+version base)))
112 (version (or version version*
113 (package-version p)))
115 ;; Use #:recursive? #t to allow for directories.
116 (source (downloaded-file uri #t))))))
123 (define (transform-package-source sources)
124 "Return a transformation procedure that replaces package sources with the
125 matching URIs given in SOURCES."
128 (match (string-index uri #\=)
130 ;; Determine the package name and version from URI.
133 (hyphen-package-name->name+version
134 (tarball-base-name (basename uri))))
135 (lambda (name version)
136 (list name version uri))))
138 ;; What's before INDEX is a "PKG@VER" or "PKG" spec.
141 (package-name->name+version (string-take uri index)))
142 (lambda (name version)
144 (string-drop uri (+ 1 index))))))))
148 (let loop ((sources new-sources)
152 (match (assoc-ref sources (package-name p))
154 (package-with-source p source version))
160 (define (evaluate-replacement-specs specs proc)
161 "Parse SPECS, a list of strings like \"guile=guile@2.1\" and return a list
162 of package spec/procedure pairs as expected by 'package-input-rewriting/spec'.
163 PROC is called with the package to be replaced and its replacement according
164 to SPECS. Raise an error if an element of SPECS uses invalid syntax, or if a
165 package it refers to could not be found."
167 (char-set-complement (char-set #\=)))
170 (match (string-tokenize spec not-equal)
173 (let ((new (specification->package new)))
177 (raise (formatted-message
178 (G_ "invalid replacement specification: ~s")
182 (define (transform-package-inputs replacement-specs)
183 "Return a procedure that, when passed a package, replaces its direct
184 dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of
185 strings like \"guile=guile@2.1\" meaning that, any dependency on a package
186 called \"guile\" must be replaced with a dependency on a version 2.1 of
188 (let* ((replacements (evaluate-replacement-specs replacement-specs
191 (rewrite (package-input-rewriting/spec replacements)))
197 (define (transform-package-inputs/graft replacement-specs)
198 "Return a procedure that, when passed a package, replaces its direct
199 dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of
200 strings like \"gnutls=gnutls@3.5.4\" meaning that packages are built using the
201 current 'gnutls' package, after which version 3.5.4 is grafted onto them."
202 (define (set-replacement old new)
203 (package (inherit old) (replacement new)))
205 (let* ((replacements (evaluate-replacement-specs replacement-specs
207 (rewrite (package-input-rewriting/spec replacements)))
214 (char-set-complement (char-set #\=)))
216 (define (package-git-url package)
217 "Return the URL of the Git repository for package, or raise an error if
218 the source of PACKAGE is not fetched from a Git repository."
219 (let ((source (package-source package)))
220 (cond ((and (origin? source)
221 (git-reference? (origin-uri source)))
222 (git-reference-url (origin-uri source)))
223 ((git-checkout? source)
224 (git-checkout-url source))
227 (formatted-message (G_ "the source of ~a is not a Git reference")
228 (package-full-name package)))))))
230 (define (evaluate-git-replacement-specs specs proc)
231 "Parse SPECS, a list of strings like \"guile=stable-2.2\", and return a list
232 of package pairs, where (PROC PACKAGE URL BRANCH-OR-COMMIT) returns the
233 replacement package. Raise an error if an element of SPECS uses invalid
234 syntax, or if a package it refers to could not be found."
236 (match (string-tokenize spec %not-equal)
237 ((spec branch-or-commit)
238 (define (replace old)
239 (let* ((source (package-source old))
240 (url (package-git-url old)))
241 (proc old url branch-or-commit)))
246 (formatted-message (G_ "invalid replacement specification: ~s")
250 (define (transform-package-source-branch replacement-specs)
251 "Return a procedure that, when passed a package, replaces its direct
252 dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of
253 strings like \"guile-next=stable-3.0\" meaning that packages are built using
254 'guile-next' from the latest commit on its 'stable-3.0' branch."
255 (define (replace old url branch)
258 (version (string-append "git." (string-map (match-lambda
262 (source (git-checkout (url url) (branch branch)
265 (let* ((replacements (evaluate-git-replacement-specs replacement-specs
267 (rewrite (package-input-rewriting/spec replacements)))
273 (define (transform-package-source-commit replacement-specs)
274 "Return a procedure that, when passed a package, replaces its direct
275 dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of
276 strings like \"guile-next=cabba9e\" meaning that packages are built using
277 'guile-next' from commit 'cabba9e'."
278 (define (replace old url commit)
281 (version (if (and (> (string-length commit) 1)
282 (string-prefix? "v" commit)
283 (char-set-contains? char-set:digit
284 (string-ref commit 1)))
285 (string-drop commit 1) ;looks like a tag like "v1.0"
286 (string-append "git."
287 (if (< (string-length commit) 7)
289 (string-take commit 7)))))
290 (source (git-checkout (url url) (commit commit)
293 (let* ((replacements (evaluate-git-replacement-specs replacement-specs
295 (rewrite (package-input-rewriting/spec replacements)))
301 (define (transform-package-source-git-url replacement-specs)
302 "Return a procedure that, when passed a package, replaces its dependencies
303 according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of strings like
304 \"guile-json=https://gitthing.com/…\" meaning that packages are built using
305 a checkout of the Git repository at the given URL."
308 (match (string-tokenize spec %not-equal)
314 (source (git-checkout (url url)
315 (recursive? #t)))))))
319 (G_ "~a: invalid Git URL replacement specification")
324 (package-input-rewriting/spec replacements))
331 (define (package-dependents/spec top bottom)
332 "Return the list of dependents of BOTTOM, a spec string, that are also
333 dependencies of TOP, a package."
334 (define-values (name version)
335 (package-name->name+version bottom))
340 (or (and (string=? name (package-name p))
342 (version-prefix? version (package-version p))))
343 (match (bag-direct-inputs (package->bag p))
344 (((labels dependencies . _) ...)
345 (any dependent? dependencies)))))))
347 (filter dependent? (package-closure (list top))))
349 (define (package-toolchain-rewriting p bottom toolchain)
350 "Return a procedure that, when passed a package that's either BOTTOM or one
351 of its dependents up to P so, changes it so it is built with TOOLCHAIN.
352 TOOLCHAIN must be an input list."
353 (define rewriting-property
354 (gensym " package-toolchain-rewriting"))
356 (match (package-dependents/spec p bottom)
357 (() ;P does not depend on BOTTOM
360 ;; SET is the list of packages "between" P and BOTTOM (included) whose
361 ;; toolchain needs to be changed.
362 (package-mapping (lambda (p)
363 (if (or (assq rewriting-property
364 (package-properties p))
367 (let ((p (package-with-c-toolchain p toolchain)))
369 (properties `((,rewriting-property . #t)
370 ,@(package-properties p)))))))
372 (or (assq rewriting-property (package-properties p))
376 (define (transform-package-toolchain replacement-specs)
377 "Return a procedure that, when passed a package, changes its toolchain or
378 that of its dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is
379 a list of strings like \"fftw=gcc-toolchain@10\" meaning that the package to
380 the left of the equal sign must be built with the toolchain to the right of
382 (define split-on-commas
383 (cute string-tokenize <> (char-set-complement (char-set #\,))))
385 (define (specification->input spec)
386 (let ((package (specification->package spec)))
387 (list (package-name package) package)))
391 (match (string-tokenize spec %not-equal)
392 ((spec (= split-on-commas toolchain))
393 (cons spec (map specification->input toolchain)))
397 (G_ "~a: invalid toolchain replacement specification")
403 (or (any (match-lambda
404 ((bottom . toolchain)
405 ((package-toolchain-rewriting obj bottom toolchain) obj)))
410 (define (transform-package-with-debug-info specs)
411 "Return a procedure that, when passed a package, set its 'replacement' field
412 to the same package but with #:strip-binaries? #f in its 'arguments' field."
413 (define (non-stripped p)
417 (substitute-keyword-arguments (package-arguments p)
418 ((#:strip-binaries? _ #f) #f)))))
420 (define (package-with-debug-info p)
421 (if (member "debug" (package-outputs p))
424 (match (package-replacement p)
428 (replacement (non-stripped p))))
432 (replacement (loop next))))))))
435 (package-input-rewriting/spec (map (lambda (spec)
436 (cons spec package-with-debug-info))
444 (define (transform-package-tests specs)
445 "Return a procedure that, when passed a package, sets #:tests? #f in its
447 (define (package-without-tests p)
450 (substitute-keyword-arguments (package-arguments p)
451 ((#:tests? _ #f) #f)))))
454 (package-input-rewriting/spec (map (lambda (spec)
455 (cons spec package-without-tests))
463 (define (transform-package-patches specs)
464 "Return a procedure that, when passed a package, returns a package with
466 (define (package-with-extra-patches p patches)
467 (if (origin? (package-source p))
470 (inherit (package-source p))
471 (patches (append (map (lambda (file)
474 (origin-patches (package-source p)))))))
477 (define (coalesce-alist alist)
478 ;; Coalesce multiple occurrences of the same key in ALIST.
479 (let loop ((alist alist)
481 (mapping vlist-null))
485 (cons key (vhash-fold* cons '() key mapping)))
486 (delete-duplicates (reverse keys))))
487 (((key . value) . rest)
490 (vhash-cons key value mapping))))))
496 (match (string-tokenize spec %not-equal)
498 (cons spec (canonicalize-path patch)))
500 (raise (formatted-message
501 (G_ "~a: invalid package patch specification")
506 (package-input-rewriting/spec
509 (cons spec (cut package-with-extra-patches <> patches))))
517 (define (transform-package-latest specs)
518 "Return a procedure that rewrites package graphs such that those in SPECS
519 are replaced by their latest upstream version."
520 (define (package-with-latest-upstream p)
521 (let ((source (package-latest-release* p)))
524 (G_ "could not determine latest upstream release of '~a'~%")
527 ((string=? (upstream-source-version source)
531 (unless (pair? (upstream-source-signature-urls source))
532 (warning (G_ "cannot authenticate source of '~a', version ~a~%")
534 (upstream-source-version source)))
536 ;; TODO: Take 'upstream-source-input-changes' into account.
539 (version (upstream-source-version source))
543 (package-input-rewriting/spec
545 (cons spec package-with-latest-upstream))
553 (define %transformations
554 ;; Transformations that can be applied to things to build. The car is the
555 ;; key used in the option alist, and the cdr is the transformation
556 ;; procedure; it is called with two arguments: the store, and a list of
558 `((with-source . ,transform-package-source)
559 (with-input . ,transform-package-inputs)
560 (with-graft . ,transform-package-inputs/graft)
561 (with-branch . ,transform-package-source-branch)
562 (with-commit . ,transform-package-source-commit)
563 (with-git-url . ,transform-package-source-git-url)
564 (with-c-toolchain . ,transform-package-toolchain)
565 (with-debug-info . ,transform-package-with-debug-info)
566 (without-tests . ,transform-package-tests)
567 (with-patch . ,transform-package-patches)
568 (with-latest . ,transform-package-latest)))
570 (define (transformation-procedure key)
571 "Return the transformation procedure associated with KEY, a symbol such as
572 'with-source', or #f if there is none."
575 (and (eq? k key) proc)))
580 ;;; Command-line handling.
583 (define %transformation-options
584 ;; The command-line interface to the above transformations.
585 (let ((parser (lambda (symbol)
586 (lambda (opt name arg result . rest)
588 (alist-cons symbol arg result)
590 (list (option '("with-source") #t #f
591 (parser 'with-source))
592 (option '("with-input") #t #f
593 (parser 'with-input))
594 (option '("with-graft") #t #f
595 (parser 'with-graft))
596 (option '("with-branch") #t #f
597 (parser 'with-branch))
598 (option '("with-commit") #t #f
599 (parser 'with-commit))
600 (option '("with-git-url") #t #f
601 (parser 'with-git-url))
602 (option '("with-c-toolchain") #t #f
603 (parser 'with-c-toolchain))
604 (option '("with-debug-info") #t #f
605 (parser 'with-debug-info))
606 (option '("without-tests") #t #f
607 (parser 'without-tests))
608 (option '("with-patch") #t #f
609 (parser 'with-patch))
610 (option '("with-latest") #t #f
611 (parser 'with-latest))
613 (option '("help-transform") #f #f
616 (G_ "Available package transformation options:~%"))
617 (show-transformation-options-help/detailed)
621 (define (show-transformation-options-help/detailed)
623 --with-source=[PACKAGE=]SOURCE
624 use SOURCE when building the corresponding package"))
626 --with-input=PACKAGE=REPLACEMENT
627 replace dependency PACKAGE by REPLACEMENT"))
629 --with-graft=PACKAGE=REPLACEMENT
630 graft REPLACEMENT on packages that refer to PACKAGE"))
632 --with-branch=PACKAGE=BRANCH
633 build PACKAGE from the latest commit of BRANCH"))
635 --with-commit=PACKAGE=COMMIT
636 build PACKAGE from COMMIT"))
638 --with-git-url=PACKAGE=URL
639 build PACKAGE from the repository at URL"))
641 --with-patch=PACKAGE=FILE
642 add FILE to the list of patches of PACKAGE"))
644 --with-latest=PACKAGE
645 use the latest upstream release of PACKAGE"))
647 --with-c-toolchain=PACKAGE=TOOLCHAIN
648 build PACKAGE and its dependents with TOOLCHAIN"))
650 --with-debug-info=PACKAGE
651 build PACKAGE and preserve its debug info"))
653 --without-tests=PACKAGE
654 build PACKAGE without running its tests")))
656 (define (show-transformation-options-help)
657 "Show basic help for package transformation options."
659 --help-transform list package transformation options not shown here")))
661 (define (options->transformation opts)
662 "Return a procedure that, when passed an object to build (package,
663 derivation, etc.), applies the transformations specified by OPTS and returns
664 the resulting objects. OPTS must be a list of symbol/string pairs such as:
666 ((with-branch . \"guile-gcrypt=master\")
667 (without-tests . \"libgcrypt\"))
669 Each symbol names a transformation and the corresponding string is an argument
670 to that transformation."
672 ;; List of applicable transformations as symbol/procedure pairs in the
673 ;; order in which they appear on the command line.
674 (filter-map (match-lambda
676 (match (transformation-procedure key)
680 ;; XXX: We used to pass TRANSFORM a list of several
681 ;; arguments, but we now pass only one, assuming that
682 ;; transform composes well.
683 (list key value (transform (list value)))))))
686 (define (package-with-transformation-properties p)
688 (properties `((transformations
689 . ,(map (match-lambda
693 ,@(package-properties p)))))
696 (define (tagged-object new)
697 (if (and (not (eq? obj new))
698 (package? new) (not (null? applicable)))
699 (package-with-transformation-properties new)
704 (((name value transform) obj)
705 (let ((new (transform obj)))
707 (warning (G_ "transformation '~a' had no effect on ~a~%")
710 (package-full-name obj)
716 (define (package-transformations package)
717 "Return the transformations applied to PACKAGE according to its properties."
718 (match (assq-ref (package-properties package) 'transformations)
720 (transformations transformations)))
722 (define (manifest-entry-with-transformations entry)
723 "Return ENTRY with an additional 'transformations' property if it's not
725 (let ((properties (manifest-entry-properties entry)))
726 (if (assq 'transformations properties)
728 (let ((item (manifest-entry-item entry)))
732 (match (and (package? item)
733 (package-transformations item))
737 `((transformations . ,transformations)
738 ,@properties)))))))))