guix/transformations.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   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.
  10 ;;;
  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.
  15 ;;;
  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/>.
  18
  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   #:use-module (guix utils)
  29   #:use-module (guix memoization)
  30   #:use-module (guix gexp)
  31
  32   ;; Use the procedure that destructures "NAME-VERSION" forms.
  33   #:use-module ((guix build utils)
  34                 #:select ((package-name->name+version
  35                            . hyphen-package-name->name+version)))
  36
  37   #:use-module (srfi srfi-1)
  38   #:use-module (srfi srfi-9)
  39   #:use-module (srfi srfi-11)
  40   #:use-module (srfi srfi-26)
  41   #:use-module (srfi srfi-34)
  42   #:use-module (srfi srfi-37)
  43   #:use-module (ice-9 match)
  44   #:export (options->transformation
  45             manifest-entry-with-transformations
  46
  47             show-transformation-options-help
  48             %transformation-options))
  49
  50 ;;; Commentary:
  51 ;;;
  52 ;;; This module implements "package transformation options"---tools for
  53 ;;; package graph rewriting.  It contains the graph rewriting logic, but also
  54 ;;; the tip of its user interface: command-line option handling.
  55 ;;;
  56 ;;; Code:
  57
  58 (module-autoload! (current-module) '(gnu packages)
  59                   '(specification->package))
  60
  61 (define (numeric-extension? file-name)
  62   "Return true if FILE-NAME ends with digits."
  63   (string-every char-set:hex-digit (file-extension file-name)))
  64
  65 (define (tarball-base-name file-name)
  66   "Return the \"base\" of FILE-NAME, removing '.tar.gz' or similar
  67 extensions."
  68   ;; TODO: Factorize.
  69   (cond ((not (file-extension file-name))
  70          file-name)
  71         ((numeric-extension? file-name)
  72          file-name)
  73         ((string=? (file-extension file-name) "tar")
  74          (file-sans-extension file-name))
  75         ((file-extension file-name)
  76          =>
  77          (match-lambda
  78            ("scm" file-name)
  79            (_     (tarball-base-name (file-sans-extension file-name)))))
  80         (else
  81          file-name)))
  82
  83
  84 ;; Files to be downloaded.
  85 (define-record-type <downloaded-file>
  86   (downloaded-file uri recursive?)
  87   downloaded-file?
  88   (uri        downloaded-file-uri)
  89   (recursive? downloaded-file-recursive?))
  90
  91 (define download-to-store*
  92   (store-lift download-to-store))
  93
  94 (define-gexp-compiler (compile-downloaded-file (file <downloaded-file>)
  95                                                system target)
  96   "Download FILE and return the result as a store item."
  97   (match file
  98     (($ <downloaded-file> uri recursive?)
  99      (download-to-store* uri #:recursive? recursive?))))
 100
 101 (define* (package-with-source p uri #:optional version)
 102   "Return a package based on P but with its source taken from URI.  Extract
 103 the new package's version number from URI."
 104   (let ((base (tarball-base-name (basename uri))))
 105     (let-values (((_ version*)
 106                   (hyphen-package-name->name+version base)))
 107       (package (inherit p)
 108                (version (or version version*
 109                             (package-version p)))
 110
 111                ;; Use #:recursive? #t to allow for directories.
 112                (source (downloaded-file uri #t))))))
 113
 114 \f
 115 ;;;
 116 ;;; Transformations.
 117 ;;;
 118
 119 (define (transform-package-source sources)
 120   "Return a transformation procedure that replaces package sources with the
 121 matching URIs given in SOURCES."
 122   (define new-sources
 123     (map (lambda (uri)
 124            (match (string-index uri #\=)
 125              (#f
 126               ;; Determine the package name and version from URI.
 127               (call-with-values
 128                   (lambda ()
 129                     (hyphen-package-name->name+version
 130                      (tarball-base-name (basename uri))))
 131                 (lambda (name version)
 132                   (list name version uri))))
 133              (index
 134               ;; What's before INDEX is a "PKG@VER" or "PKG" spec.
 135               (call-with-values
 136                   (lambda ()
 137                     (package-name->name+version (string-take uri index)))
 138                 (lambda (name version)
 139                   (list name version
 140                         (string-drop uri (+ 1 index))))))))
 141          sources))
 142
 143   (lambda (obj)
 144     (let loop ((sources  new-sources)
 145                (result   '()))
 146       (match obj
 147         ((? package? p)
 148          (match (assoc-ref sources (package-name p))
 149            ((version source)
 150             (package-with-source p source version))
 151            (#f
 152             p)))
 153         (_
 154          obj)))))
 155
 156 (define (evaluate-replacement-specs specs proc)
 157   "Parse SPECS, a list of strings like \"guile=guile@2.1\" and return a list
 158 of package spec/procedure pairs as expected by 'package-input-rewriting/spec'.
 159 PROC is called with the package to be replaced and its replacement according
 160 to SPECS.  Raise an error if an element of SPECS uses invalid syntax, or if a
 161 package it refers to could not be found."
 162   (define not-equal
 163     (char-set-complement (char-set #\=)))
 164
 165   (map (lambda (spec)
 166          (match (string-tokenize spec not-equal)
 167            ((spec new)
 168             (cons spec
 169                   (let ((new (specification->package new)))
 170                     (lambda (old)
 171                       (proc old new)))))
 172            (x
 173             (raise (formatted-message
 174                     (G_ "invalid replacement specification: ~s")
 175                     spec)))))
 176        specs))
 177
 178 (define (transform-package-inputs replacement-specs)
 179   "Return a procedure that, when passed a package, replaces its direct
 180 dependencies according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of
 181 strings like \"guile=guile@2.1\" meaning that, any dependency on a package
 182 called \"guile\" must be replaced with a dependency on a version 2.1 of
 183 \"guile\"."
 184   (let* ((replacements (evaluate-replacement-specs replacement-specs
 185                                                    (lambda (old new)
 186                                                      new)))
 187          (rewrite      (package-input-rewriting/spec replacements)))
 188     (lambda (obj)
 189       (if (package? obj)
 190           (rewrite obj)
 191           obj))))
 192
 193 (define (transform-package-inputs/graft replacement-specs)
 194   "Return a procedure that, when passed a package, replaces its direct
 195 dependencies according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of
 196 strings like \"gnutls=gnutls@3.5.4\" meaning that packages are built using the
 197 current 'gnutls' package, after which version 3.5.4 is grafted onto them."
 198   (define (set-replacement old new)
 199     (package (inherit old) (replacement new)))
 200
 201   (let* ((replacements (evaluate-replacement-specs replacement-specs
 202                                                    set-replacement))
 203          (rewrite      (package-input-rewriting/spec replacements)))
 204     (lambda (obj)
 205       (if (package? obj)
 206           (rewrite obj)
 207           obj))))
 208
 209 (define %not-equal
 210   (char-set-complement (char-set #\=)))
 211
 212 (define (package-git-url package)
 213   "Return the URL of the Git repository for package, or raise an error if
 214 the source of PACKAGE is not fetched from a Git repository."
 215   (let ((source (package-source package)))
 216     (cond ((and (origin? source)
 217                 (git-reference? (origin-uri source)))
 218            (git-reference-url (origin-uri source)))
 219           ((git-checkout? source)
 220            (git-checkout-url source))
 221           (else
 222            (raise
 223             (formatted-message (G_ "the source of ~a is not a Git reference")
 224                                (package-full-name package)))))))
 225
 226 (define (evaluate-git-replacement-specs specs proc)
 227   "Parse SPECS, a list of strings like \"guile=stable-2.2\", and return a list
 228 of package pairs, where (PROC PACKAGE URL BRANCH-OR-COMMIT) returns the
 229 replacement package.  Raise an error if an element of SPECS uses invalid
 230 syntax, or if a package it refers to could not be found."
 231   (map (lambda (spec)
 232          (match (string-tokenize spec %not-equal)
 233            ((spec branch-or-commit)
 234             (define (replace old)
 235               (let* ((source (package-source old))
 236                      (url    (package-git-url old)))
 237                 (proc old url branch-or-commit)))
 238
 239             (cons spec replace))
 240            (_
 241             (raise
 242              (formatted-message (G_ "invalid replacement specification: ~s")
 243                                 spec)))))
 244        specs))
 245
 246 (define (transform-package-source-branch replacement-specs)
 247   "Return a procedure that, when passed a package, replaces its direct
 248 dependencies according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of
 249 strings like \"guile-next=stable-3.0\" meaning that packages are built using
 250 'guile-next' from the latest commit on its 'stable-3.0' branch."
 251   (define (replace old url branch)
 252     (package
 253       (inherit old)
 254       (version (string-append "git." (string-map (match-lambda
 255                                                    (#\/ #\-)
 256                                                    (chr chr))
 257                                                  branch)))
 258       (source (git-checkout (url url) (branch branch)
 259                             (recursive? #t)))))
 260
 261   (let* ((replacements (evaluate-git-replacement-specs replacement-specs
 262                                                        replace))
 263          (rewrite      (package-input-rewriting/spec replacements)))
 264     (lambda (obj)
 265       (if (package? obj)
 266           (rewrite obj)
 267           obj))))
 268
 269 (define (transform-package-source-commit replacement-specs)
 270   "Return a procedure that, when passed a package, replaces its direct
 271 dependencies according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of
 272 strings like \"guile-next=cabba9e\" meaning that packages are built using
 273 'guile-next' from commit 'cabba9e'."
 274   (define (replace old url commit)
 275     (package
 276       (inherit old)
 277       (version (if (and (> (string-length commit) 1)
 278                         (string-prefix? "v" commit)
 279                         (char-set-contains? char-set:digit
 280                                             (string-ref commit 1)))
 281                    (string-drop commit 1)        ;looks like a tag like "v1.0"
 282                    (string-append "git."
 283                                   (if (< (string-length commit) 7)
 284                                       commit
 285                                       (string-take commit 7)))))
 286       (source (git-checkout (url url) (commit commit)
 287                             (recursive? #t)))))
 288
 289   (let* ((replacements (evaluate-git-replacement-specs replacement-specs
 290                                                        replace))
 291          (rewrite      (package-input-rewriting/spec replacements)))
 292     (lambda (obj)
 293       (if (package? obj)
 294           (rewrite obj)
 295           obj))))
 296
 297 (define (transform-package-source-git-url replacement-specs)
 298   "Return a procedure that, when passed a package, replaces its dependencies
 299 according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of strings like
 300 \"guile-json=https://gitthing.com/…\" meaning that packages are built using
 301 a checkout of the Git repository at the given URL."
 302   (define replacements
 303     (map (lambda (spec)
 304            (match (string-tokenize spec %not-equal)
 305              ((spec url)
 306               (cons spec
 307                     (lambda (old)
 308                       (package
 309                         (inherit old)
 310                         (source (git-checkout (url url)
 311                                               (recursive? #t)))))))
 312              (_
 313               (raise
 314                (formatted-message
 315                 (G_ "~a: invalid Git URL replacement specification")
 316                 spec)))))
 317          replacement-specs))
 318
 319   (define rewrite
 320     (package-input-rewriting/spec replacements))
 321
 322   (lambda (obj)
 323     (if (package? obj)
 324         (rewrite obj)
 325         obj)))
 326
 327 (define (package-dependents/spec top bottom)
 328   "Return the list of dependents of BOTTOM, a spec string, that are also
 329 dependencies of TOP, a package."
 330   (define-values (name version)
 331     (package-name->name+version bottom))
 332
 333   (define dependent?
 334     (mlambda (p)
 335       (and (package? p)
 336            (or (and (string=? name (package-name p))
 337                     (or (not version)
 338                         (version-prefix? version (package-version p))))
 339                (match (bag-direct-inputs (package->bag p))
 340                  (((labels dependencies . _) ...)
 341                   (any dependent? dependencies)))))))
 342
 343   (filter dependent? (package-closure (list top))))
 344
 345 (define (package-toolchain-rewriting p bottom toolchain)
 346   "Return a procedure that, when passed a package that's either BOTTOM or one
 347 of its dependents up to P so, changes it so it is built with TOOLCHAIN.
 348 TOOLCHAIN must be an input list."
 349   (define rewriting-property
 350     (gensym " package-toolchain-rewriting"))
 351
 352   (match (package-dependents/spec p bottom)
 353     (()                                           ;P does not depend on BOTTOM
 354      identity)
 355     (set
 356      ;; SET is the list of packages "between" P and BOTTOM (included) whose
 357      ;; toolchain needs to be changed.
 358      (package-mapping (lambda (p)
 359                         (if (or (assq rewriting-property
 360                                       (package-properties p))
 361                                 (not (memq p set)))
 362                             p
 363                             (let ((p (package-with-c-toolchain p toolchain)))
 364                               (package/inherit p
 365                                 (properties `((,rewriting-property . #t)
 366                                               ,@(package-properties p)))))))
 367                       (lambda (p)
 368                         (or (assq rewriting-property (package-properties p))
 369                             (not (memq p set))))
 370                       #:deep? #t))))
 371
 372 (define (transform-package-toolchain replacement-specs)
 373   "Return a procedure that, when passed a package, changes its toolchain or
 374 that of its dependencies according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is
 375 a list of strings like \"fftw=gcc-toolchain@10\" meaning that the package to
 376 the left of the equal sign must be built with the toolchain to the right of
 377 the equal sign."
 378   (define split-on-commas
 379     (cute string-tokenize <> (char-set-complement (char-set #\,))))
 380
 381   (define (specification->input spec)
 382     (let ((package (specification->package spec)))
 383       (list (package-name package) package)))
 384
 385   (define replacements
 386     (map (lambda (spec)
 387            (match (string-tokenize spec %not-equal)
 388              ((spec (= split-on-commas toolchain))
 389               (cons spec (map specification->input toolchain)))
 390              (_
 391               (raise
 392                (formatted-message
 393                 (G_ "~a: invalid toolchain replacement specification")
 394                 spec)))))
 395          replacement-specs))
 396
 397   (lambda (obj)
 398     (if (package? obj)
 399         (or (any (match-lambda
 400                    ((bottom . toolchain)
 401                     ((package-toolchain-rewriting obj bottom toolchain) obj)))
 402                  replacements)
 403             obj)
 404         obj)))
 405
 406 (define (transform-package-with-debug-info specs)
 407   "Return a procedure that, when passed a package, set its 'replacement' field
 408 to the same package but with #:strip-binaries? #f in its 'arguments' field."
 409   (define (non-stripped p)
 410     (package
 411       (inherit p)
 412       (arguments
 413        (substitute-keyword-arguments (package-arguments p)
 414          ((#:strip-binaries? _ #f) #f)))))
 415
 416   (define (package-with-debug-info p)
 417     (if (member "debug" (package-outputs p))
 418         p
 419         (let loop ((p p))
 420           (match (package-replacement p)
 421             (#f
 422              (package
 423                (inherit p)
 424                (replacement (non-stripped p))))
 425             (next
 426              (package
 427                (inherit p)
 428                (replacement (loop next))))))))
 429
 430   (define rewrite
 431     (package-input-rewriting/spec (map (lambda (spec)
 432                                          (cons spec package-with-debug-info))
 433                                        specs)))
 434
 435   (lambda (obj)
 436     (if (package? obj)
 437         (rewrite obj)
 438         obj)))
 439
 440 (define (transform-package-tests specs)
 441   "Return a procedure that, when passed a package, sets #:tests? #f in its
 442 'arguments' field."
 443   (define (package-without-tests p)
 444     (package/inherit p
 445       (arguments
 446        (substitute-keyword-arguments (package-arguments p)
 447          ((#:tests? _ #f) #f)))))
 448
 449   (define rewrite
 450     (package-input-rewriting/spec (map (lambda (spec)
 451                                          (cons spec package-without-tests))
 452                                        specs)))
 453
 454   (lambda (obj)
 455     (if (package? obj)
 456         (rewrite obj)
 457         obj)))
 458
 459 (define %transformations
 460   ;; Transformations that can be applied to things to build.  The car is the
 461   ;; key used in the option alist, and the cdr is the transformation
 462   ;; procedure; it is called with two arguments: the store, and a list of
 463   ;; things to build.
 464   `((with-source . ,transform-package-source)
 465     (with-input  . ,transform-package-inputs)
 466     (with-graft  . ,transform-package-inputs/graft)
 467     (with-branch . ,transform-package-source-branch)
 468     (with-commit . ,transform-package-source-commit)
 469     (with-git-url . ,transform-package-source-git-url)
 470     (with-c-toolchain . ,transform-package-toolchain)
 471     (with-debug-info . ,transform-package-with-debug-info)
 472     (without-tests . ,transform-package-tests)))
 473
 474 (define (transformation-procedure key)
 475   "Return the transformation procedure associated with KEY, a symbol such as
 476 'with-source', or #f if there is none."
 477   (any (match-lambda
 478          ((k . proc)
 479           (and (eq? k key) proc)))
 480        %transformations))
 481
 482 \f
 483 ;;;
 484 ;;; Command-line handling.
 485 ;;;
 486
 487 (define %transformation-options
 488   ;; The command-line interface to the above transformations.
 489   (let ((parser (lambda (symbol)
 490                   (lambda (opt name arg result . rest)
 491                     (apply values
 492                            (alist-cons symbol arg result)
 493                            rest)))))
 494     (list (option '("with-source") #t #f
 495                   (parser 'with-source))
 496           (option '("with-input") #t #f
 497                   (parser 'with-input))
 498           (option '("with-graft") #t #f
 499                   (parser 'with-graft))
 500           (option '("with-branch") #t #f
 501                   (parser 'with-branch))
 502           (option '("with-commit") #t #f
 503                   (parser 'with-commit))
 504           (option '("with-git-url") #t #f
 505                   (parser 'with-git-url))
 506           (option '("with-c-toolchain") #t #f
 507                   (parser 'with-c-toolchain))
 508           (option '("with-debug-info") #t #f
 509                   (parser 'with-debug-info))
 510           (option '("without-tests") #t #f
 511                   (parser 'without-tests)))))
 512
 513 (define (show-transformation-options-help)
 514   (display (G_ "
 515       --with-source=[PACKAGE=]SOURCE
 516                          use SOURCE when building the corresponding package"))
 517   (display (G_ "
 518       --with-input=PACKAGE=REPLACEMENT
 519                          replace dependency PACKAGE by REPLACEMENT"))
 520   (display (G_ "
 521       --with-graft=PACKAGE=REPLACEMENT
 522                          graft REPLACEMENT on packages that refer to PACKAGE"))
 523   (display (G_ "
 524       --with-branch=PACKAGE=BRANCH
 525                          build PACKAGE from the latest commit of BRANCH"))
 526   (display (G_ "
 527       --with-commit=PACKAGE=COMMIT
 528                          build PACKAGE from COMMIT"))
 529   (display (G_ "
 530       --with-git-url=PACKAGE=URL
 531                          build PACKAGE from the repository at URL"))
 532   (display (G_ "
 533       --with-c-toolchain=PACKAGE=TOOLCHAIN
 534                          build PACKAGE and its dependents with TOOLCHAIN"))
 535   (display (G_ "
 536       --with-debug-info=PACKAGE
 537                          build PACKAGE and preserve its debug info"))
 538   (display (G_ "
 539       --without-tests=PACKAGE
 540                          build PACKAGE without running its tests")))
 541
 542
 543 (define (options->transformation opts)
 544   "Return a procedure that, when passed an object to build (package,
 545 derivation, etc.), applies the transformations specified by OPTS and returns
 546 the resulting objects.  OPTS must be a list of symbol/string pairs such as:
 547
 548   ((with-branch . \"guile-gcrypt=master\")
 549    (without-tests . \"libgcrypt\"))
 550
 551 Each symbol names a transformation and the corresponding string is an argument
 552 to that transformation."
 553   (define applicable
 554     ;; List of applicable transformations as symbol/procedure pairs in the
 555     ;; order in which they appear on the command line.
 556     (filter-map (match-lambda
 557                   ((key . value)
 558                    (match (transformation-procedure key)
 559                      (#f
 560                       #f)
 561                      (transform
 562                       ;; XXX: We used to pass TRANSFORM a list of several
 563                       ;; arguments, but we now pass only one, assuming that
 564                       ;; transform composes well.
 565                       (list key value (transform (list value)))))))
 566                 (reverse opts)))
 567
 568   (define (package-with-transformation-properties p)
 569     (package/inherit p
 570       (properties `((transformations
 571                      . ,(map (match-lambda
 572                                ((key value _)
 573                                 (cons key value)))
 574                              applicable))
 575                     ,@(package-properties p)))))
 576
 577   (lambda (obj)
 578     (define (tagged-object new)
 579       (if (and (not (eq? obj new))
 580                (package? new) (not (null? applicable)))
 581           (package-with-transformation-properties new)
 582           new))
 583
 584     (tagged-object
 585      (fold (match-lambda*
 586              (((name value transform) obj)
 587               (let ((new (transform obj)))
 588                 (when (eq? new obj)
 589                   (warning (G_ "transformation '~a' had no effect on ~a~%")
 590                            name
 591                            (if (package? obj)
 592                                (package-full-name obj)
 593                                obj)))
 594                 new)))
 595            obj
 596            applicable))))
 597
 598 (define (package-transformations package)
 599   "Return the transformations applied to PACKAGE according to its properties."
 600   (match (assq-ref (package-properties package) 'transformations)
 601     (#f '())
 602     (transformations transformations)))
 603
 604 (define (manifest-entry-with-transformations entry)
 605   "Return ENTRY with an additional 'transformations' property if it's not
 606 already there."
 607   (let ((properties (manifest-entry-properties entry)))
 608     (if (assq 'transformations properties)
 609         entry
 610         (let ((item (manifest-entry-item entry)))
 611           (manifest-entry
 612             (inherit entry)
 613             (properties
 614              (match (and (package? item)
 615                          (package-transformations item))
 616                ((or #f '())
 617                 properties)
 618                (transformations
 619                 `((transformations . ,transformations)
 620                   ,@properties)))))))))