tests/transformations.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016-2017, 2019-2022 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2021 Marius Bakke <marius@gnu.org>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (test-transformations)
  21   #:use-module (guix tests)
  22   #:use-module (guix store)
  23   #:use-module ((guix gexp) #:select (lower-object))
  24   #:use-module ((guix profiles)
  25                 #:select (package->manifest-entry
  26                           manifest-entry-properties))
  27   #:use-module (guix derivations)
  28   #:use-module (guix packages)
  29   #:use-module (guix git-download)
  30   #:use-module (guix build-system)
  31   #:use-module (guix build-system gnu)
  32   #:use-module (guix transformations)
  33   #:use-module ((guix gexp)
  34                 #:select (local-file? local-file-file
  35                           computed-file? computed-file-gexp
  36                           gexp-input-thing))
  37   #:use-module (guix ui)
  38   #:use-module (guix utils)
  39   #:use-module (guix git)
  40   #:use-module (guix upstream)
  41   #:use-module (guix diagnostics)
  42   #:use-module (gnu packages)
  43   #:use-module (gnu packages base)
  44   #:use-module (gnu packages busybox)
  45   #:use-module (ice-9 match)
  46   #:use-module (srfi srfi-1)
  47   #:use-module (srfi srfi-26)
  48   #:use-module (srfi srfi-34)
  49   #:use-module (srfi srfi-64))
  50
  51 \f
  52 (test-begin "transformations")
  53
  54 (test-assert "options->transformation, no transformations"
  55   (let ((p (dummy-package "foo"))
  56         (t (options->transformation '())))
  57     (eq? (t p) p)))
  58
  59 (test-assert "options->transformation, with-source"
  60   ;; Our pseudo-package is called 'guix.scm' so the 'guix.scm' source should
  61   ;; be applicable.
  62   (let* ((p (dummy-package "guix.scm"))
  63          (s (search-path %load-path "guix.scm"))
  64          (t (options->transformation `((with-source . ,s)))))
  65     (with-store store
  66       (let* ((new (t p))
  67              (source (run-with-store store
  68                        (lower-object (package-source new)))))
  69         (and (not (eq? new p))
  70              (string=? source
  71                        (add-to-store store "guix.scm" #t
  72                                      "sha256" s)))))))
  73
  74 (test-assert "options->transformation, with-source, replacement"
  75   ;; Same, but this time the original package has a 'replacement' field.  We
  76   ;; expect that replacement to be set to #f in the new package.
  77   (let* ((p (dummy-package "guix.scm" (replacement coreutils)))
  78          (s (search-path %load-path "guix.scm"))
  79          (t (options->transformation `((with-source . ,s)))))
  80     (let ((new (t p)))
  81       (and (not (eq? new p))
  82            (not (package-replacement new))))))
  83
  84 (test-assert "options->transformation, with-source, with version"
  85   ;; Our pseudo-package is called 'guix.scm' so the 'guix.scm-2.0' source
  86   ;; should be applicable, and its version should be extracted.
  87   (let ((p (dummy-package "foo"))
  88         (s (search-path %load-path "guix.scm")))
  89     (call-with-temporary-directory
  90      (lambda (directory)
  91        (let* ((f (string-append directory "/foo-42.0.tar.gz"))
  92               (t (options->transformation `((with-source . ,f)))))
  93          (copy-file s f)
  94          (with-store store
  95            (let* ((new (t p))
  96                   (source (run-with-store store
  97                             (lower-object (package-source new)))))
  98              (and (not (eq? new p))
  99                   (string=? (package-name new) (package-name p))
 100                   (string=? (package-version new) "42.0")
 101                   (string=? source
 102                             (add-to-store store (basename f) #t
 103                                           "sha256" f))))))))))
 104
 105 (test-assert "options->transformation, with-source, no matches"
 106   (let* ((p (dummy-package "foobar"))
 107          (s (search-path %load-path "guix.scm"))
 108          (t (options->transformation `((with-source . ,s)))))
 109     (eq? (package-source (t p))
 110          (package-source p))))
 111
 112 (test-assert "options->transformation, with-source, PKG=URI"
 113   (let* ((p (dummy-package "foo"))
 114          (s (search-path %load-path "guix.scm"))
 115          (f (string-append "foo=" s))
 116          (t (options->transformation `((with-source . ,f)))))
 117     (with-store store
 118       (let* ((new (t p))
 119              (source (run-with-store store
 120                        (lower-object (package-source new)))))
 121         (and (not (eq? new p))
 122              (string=? (package-name new) (package-name p))
 123              (string=? (package-version new)
 124                        (package-version p))
 125              (string=? source
 126                        (add-to-store store (basename s) #t
 127                                      "sha256" s)))))))
 128
 129 (test-assert "options->transformation, with-source, PKG@VER=URI"
 130   (let* ((p (dummy-package "foo"))
 131          (s (search-path %load-path "guix.scm"))
 132          (f (string-append "foo@42.0=" s))
 133          (t (options->transformation `((with-source . ,f)))))
 134     (with-store store
 135       (let* ((new (t p))
 136              (source (run-with-store store
 137                        (lower-object (package-source new)))))
 138         (and (not (eq? new p))
 139              (string=? (package-name new) (package-name p))
 140              (string=? (package-version new) "42.0")
 141              (string=? source
 142                        (add-to-store store (basename s) #t
 143                                      "sha256" s)))))))
 144
 145 (test-assert "options->transformation, with-source, in depth"
 146   (let* ((p0 (dummy-package "foo" (version "0.0")))
 147          (s  (search-path %load-path "guix.scm"))
 148          (f  (string-append "foo@42.0=" s))
 149          (t  (options->transformation `((with-source . ,f))))
 150          (p1 (dummy-package "bar" (inputs (list p0))))
 151          (p2 (dummy-package "baz" (inputs (list p1)))))
 152     (with-store store
 153       (let ((new (t p2)))
 154         (and (not (eq? new p2))
 155              (match (package-inputs new)
 156                ((("bar" p1*))
 157                 (match (package-inputs p1*)
 158                   ((("foo" p0*))
 159                    (and (not (eq? p0* p0))
 160                         (string=? (package-name p0*) (package-name p0))
 161                         (string=? (package-version p0*) "42.0")
 162                         (string=? (add-to-store store (basename s) #t
 163                                                 "sha256" s)
 164                                   (run-with-store store
 165                                     (lower-object
 166                                      (package-source p0*))))))))))))))
 167
 168 (test-assert "options->transformation, with-input"
 169   (let* ((p (dummy-package "guix.scm"
 170               (inputs `(("foo" ,(specification->package "coreutils"))
 171                         ("bar" ,(specification->package "grep"))
 172                         ("baz" ,(dummy-package "chbouib"
 173                                   (native-inputs `(("x" ,grep)))))))))
 174          (t (options->transformation '((with-input . "coreutils=busybox")
 175                                        (with-input . "grep=findutils")))))
 176     (let ((new (t p)))
 177       (and (not (eq? new p))
 178            (match (package-inputs new)
 179              ((("foo" dep1) ("bar" dep2) ("baz" dep3))
 180               (and (string=? (package-full-name dep1)
 181                              (package-full-name busybox))
 182                    (string=? (package-full-name dep2)
 183                              (package-full-name findutils))
 184                    (string=? (package-name dep3) "chbouib")
 185                    (match (package-native-inputs dep3)
 186                      ((("x" dep))
 187                       (string=? (package-full-name dep)
 188                                 (package-full-name findutils)))))))))))
 189
 190 (test-assert "options->transformation, with-graft"
 191   (let* ((p (dummy-package "guix.scm"
 192               (inputs `(("foo" ,grep)
 193                         ("bar" ,(dummy-package "chbouib"
 194                                   (native-inputs `(("x" ,grep)))))))))
 195          (t (options->transformation '((with-graft . "grep=findutils")))))
 196     (let ((new (t p)))
 197       (and (not (eq? new p))
 198            (match (package-inputs new)
 199              ((("foo" dep1) ("bar" dep2))
 200               (and (string=? (package-full-name dep1)
 201                              (package-full-name grep))
 202                    (string=? (package-full-name (package-replacement dep1))
 203                              (package-full-name findutils))
 204                    (string=? (package-name dep2) "chbouib")
 205                    (match (package-native-inputs dep2)
 206                      ((("x" dep))
 207                       (with-store store
 208                         (string=? (derivation-file-name
 209                                    (package-derivation store findutils))
 210                                   (derivation-file-name
 211                                    (package-derivation store dep)))))))))))))
 212
 213 (test-equal "options->transformation, with-branch"
 214   (git-checkout (url "https://example.org")
 215                 (branch "devel")
 216                 (recursive? #t))
 217   (let* ((p (dummy-package "guix.scm"
 218               (inputs `(("foo" ,grep)
 219                         ("bar" ,(dummy-package "chbouib"
 220                                   (source (origin
 221                                             (method git-fetch)
 222                                             (uri (git-reference
 223                                                   (url "https://example.org")
 224                                                   (commit "cabba9e")))
 225                                             (sha256 #f)))))))))
 226          (t (options->transformation '((with-branch . "chbouib=devel")))))
 227     (let ((new (t p)))
 228       (and (not (eq? new p))
 229            (match (package-inputs new)
 230              ((("foo" dep1) ("bar" dep2))
 231               (and (string=? (package-full-name dep1)
 232                              (package-full-name grep))
 233                    (string=? (package-name dep2) "chbouib")
 234                    (package-source dep2))))))))
 235
 236 (test-equal "options->transformation, with-commit"
 237   (git-checkout (url "https://example.org")
 238                 (commit "abcdef")
 239                 (recursive? #t))
 240   (let* ((p (dummy-package "guix.scm"
 241               (inputs `(("foo" ,grep)
 242                         ("bar" ,(dummy-package "chbouib"
 243                                   (source (origin
 244                                             (method git-fetch)
 245                                             (uri (git-reference
 246                                                   (url "https://example.org")
 247                                                   (commit "cabba9e")))
 248                                             (sha256 #f)))))))))
 249          (t (options->transformation '((with-commit . "chbouib=abcdef")))))
 250     (let ((new (t p)))
 251       (and (not (eq? new p))
 252            (match (package-inputs new)
 253              ((("foo" dep1) ("bar" dep2))
 254               (and (string=? (package-full-name dep1)
 255                              (package-full-name grep))
 256                    (string=? (package-name dep2) "chbouib")
 257                    (package-source dep2))))))))
 258
 259 (test-equal "options->transformation, with-commit, version transformation"
 260   '("1.0" "1.0-rc1-2-gabc123" "git.abc123")
 261   (map (lambda (commit)
 262          (let* ((p (dummy-package "guix.scm"
 263                      (inputs `(("foo" ,(dummy-package "chbouib"
 264                                          (source (origin
 265                                                    (method git-fetch)
 266                                                    (uri (git-reference
 267                                                          (url "https://example.org")
 268                                                          (commit "cabba9e")))
 269                                                    (sha256 #f)))))))))
 270                 (t (options->transformation
 271                     `((with-commit . ,(string-append "chbouib=" commit))))))
 272            (let ((new (t p)))
 273              (and (not (eq? new p))
 274                   (match (package-inputs new)
 275                     ((("foo" dep1))
 276                      (package-version dep1)))))))
 277        '("v1.0" "1.0-rc1-2-gabc123" "abc123")))
 278
 279 (test-equal "options->transformation, with-git-url"
 280   (let ((source (git-checkout (url "https://example.org")
 281                               (recursive? #t))))
 282     (list source source))
 283   (let* ((p (dummy-package "guix.scm"
 284               (inputs `(("foo" ,grep)
 285                         ("bar" ,(dummy-package "chbouib"
 286                                   (native-inputs `(("x" ,grep)))))))))
 287          (t (options->transformation '((with-git-url . "grep=https://example.org")))))
 288     (let ((new (t p)))
 289       (and (not (eq? new p))
 290            (match (package-inputs new)
 291              ((("foo" dep1) ("bar" dep2))
 292               (and (string=? (package-full-name dep1)
 293                              (package-full-name grep))
 294                    (string=? (package-name dep2) "chbouib")
 295                    (match (package-native-inputs dep2)
 296                      ((("x" dep3))
 297                       (map package-source (list dep1 dep3)))))))))))
 298
 299 (test-equal "options->transformation, with-git-url + with-branch"
 300   ;; Combine the two options and make sure the 'with-branch' transformation
 301   ;; comes after the 'with-git-url' transformation.
 302   (let ((source (git-checkout (url "https://example.org")
 303                               (branch "BRANCH")
 304                               (recursive? #t))))
 305     (list source source))
 306   (let* ((p (dummy-package "guix.scm"
 307               (inputs `(("foo" ,grep)
 308                         ("bar" ,(dummy-package "chbouib"
 309                                   (native-inputs `(("x" ,grep)))))))))
 310          (t (options->transformation
 311              (reverse '((with-git-url
 312                          . "grep=https://example.org")
 313                         (with-branch . "grep=BRANCH"))))))
 314     (let ((new (t p)))
 315       (and (not (eq? new p))
 316            (match (package-inputs new)
 317              ((("foo" dep1) ("bar" dep2))
 318               (and (string=? (package-name dep1) "grep")
 319                    (string=? (package-name dep2) "chbouib")
 320                    (match (package-native-inputs dep2)
 321                      ((("x" dep3))
 322                       (map package-source (list dep1 dep3)))))))))))
 323
 324 (define* (depends-on-toolchain? p #:optional (toolchain "gcc-toolchain"))
 325   "Return true if P depends on TOOLCHAIN instead of the default tool chain."
 326   (define toolchain-packages
 327     '("gcc" "binutils" "glibc" "ld-wrapper"))
 328
 329   (define (package-name* obj)
 330     (and (package? obj) (package-name obj)))
 331
 332   (match (bag-build-inputs (package->bag p))
 333     (((_ (= package-name* packages) . _) ...)
 334      (and (not (any (cut member <> packages) toolchain-packages))
 335           (member toolchain packages)))))
 336
 337 (test-assert "options->transformation, with-c-toolchain"
 338   (let* ((dep0 (dummy-package "chbouib"
 339                  (build-system gnu-build-system)
 340                  (native-inputs `(("y" ,grep)))))
 341          (dep1 (dummy-package "stuff"
 342                  (native-inputs `(("x" ,dep0)))))
 343          (p    (dummy-package "thingie"
 344                  (build-system gnu-build-system)
 345                  (inputs `(("foo" ,grep)
 346                            ("bar" ,dep1)))))
 347          (t    (options->transformation
 348                 '((with-c-toolchain . "chbouib=gcc-toolchain")))))
 349     ;; Here we check that the transformation applies to DEP0 and all its
 350     ;; dependents: DEP0 must use GCC-TOOLCHAIN, DEP1 must use GCC-TOOLCHAIN
 351     ;; and the DEP0 that uses GCC-TOOLCHAIN, and so on.
 352     (let ((new (t p)))
 353       (and (depends-on-toolchain? new "gcc-toolchain")
 354            (match (bag-build-inputs (package->bag new))
 355              ((("foo" dep0) ("bar" dep1) _ ...)
 356               (and (depends-on-toolchain? dep1 "gcc-toolchain")
 357                    (not (depends-on-toolchain? dep0 "gcc-toolchain"))
 358                    (string=? (package-full-name dep0)
 359                              (package-full-name grep))
 360                    (match (bag-build-inputs (package->bag dep1))
 361                      ((("x" dep) _ ...)
 362                       (and (depends-on-toolchain? dep "gcc-toolchain")
 363                            (match (bag-build-inputs (package->bag dep))
 364                              ((("y" dep) _ ...)   ;this one is unchanged
 365                               (eq? dep grep)))))))))))))
 366
 367 (test-equal "options->transformation, with-c-toolchain twice"
 368   (package-full-name grep)
 369   (let* ((dep0 (dummy-package "chbouib"))
 370          (dep1 (dummy-package "stuff"))
 371          (p    (dummy-package "thingie"
 372                  (build-system gnu-build-system)
 373                  (inputs `(("foo" ,dep0)
 374                            ("bar" ,dep1)
 375                            ("baz" ,grep)))))
 376          (t    (options->transformation
 377                 '((with-c-toolchain . "chbouib=clang-toolchain")
 378                   (with-c-toolchain . "stuff=clang-toolchain")))))
 379     (let ((new (t p)))
 380       (and (depends-on-toolchain? new "clang-toolchain")
 381            (match (bag-build-inputs (package->bag new))
 382              ((("foo" dep0) ("bar" dep1) ("baz" dep2) _ ...)
 383               (and (depends-on-toolchain? dep0 "clang-toolchain")
 384                    (depends-on-toolchain? dep1 "clang-toolchain")
 385                    (not (depends-on-toolchain? dep2 "clang-toolchain"))
 386                    (package-full-name dep2))))))))
 387
 388 (test-assert "options->transformation, with-c-toolchain, no effect"
 389   (let ((p (dummy-package "thingie"))
 390         (t (options->transformation
 391             '((with-c-toolchain . "does-not-exist=gcc-toolchain")))))
 392     ;; When it has no effect, '--with-c-toolchain' returns P.
 393     (eq? (t p) p)))
 394
 395 (test-equal "options->transformation, with-debug-info"
 396   '(#:strip-binaries? #f)
 397   (let* ((dep  (dummy-package "chbouib"))
 398          (p    (dummy-package "thingie"
 399                  (build-system gnu-build-system)
 400                  (inputs `(("foo" ,dep)
 401                            ("bar" ,grep)))))
 402          (t    (options->transformation
 403                 '((with-debug-info . "chbouib")))))
 404     (let ((new (t p)))
 405       (match (package-inputs new)
 406         ((("foo" dep0) ("bar" dep1))
 407          (and (string=? (package-full-name dep1)
 408                         (package-full-name grep))
 409               (package-arguments (package-replacement dep0))))))))
 410
 411 (test-assert "options->transformation, without-tests"
 412   (let* ((dep (dummy-package "dep"))
 413          (p   (dummy-package "foo"
 414                 (inputs `(("dep" ,dep)))))
 415          (t   (options->transformation '((without-tests . "dep")
 416                                          (without-tests . "tar")))))
 417     (let ((new (t p)))
 418       (match (bag-direct-inputs (package->bag new))
 419         ((("dep" dep) ("tar" tar) _ ...)
 420          (and (equal? (package-arguments dep) '(#:tests? #f))
 421               (match (memq #:tests? (package-arguments tar))
 422                 ((#:tests? #f _ ...) #t))))))))
 423
 424 (test-equal "options->transformation, with-patch"
 425   (search-patches "glibc-locales.patch" "guile-relocatable.patch")
 426   (let* ((dep    (dummy-package "dep"
 427                    (source (dummy-origin))))
 428          (p      (dummy-package "foo"
 429                    (inputs `(("dep" ,dep)))))
 430          (patch1 (search-patch "glibc-locales.patch"))
 431          (patch2 (search-patch "guile-relocatable.patch"))
 432          (t      (options->transformation
 433                   `((with-patch . ,(string-append "dep=" patch1))
 434                     (with-patch . ,(string-append "dep=" patch2))
 435                     (with-patch . ,(string-append "tar=" patch1))))))
 436     (let ((new (t p)))
 437       (match (bag-direct-inputs (package->bag new))
 438         ((("dep" dep) ("tar" tar) _ ...)
 439          (and (member patch1
 440                       (filter-map (lambda (patch)
 441                                     (and (local-file? patch)
 442                                          (local-file-file patch)))
 443                                   (origin-patches (package-source tar))))
 444               (map local-file-file
 445                    (origin-patches (package-source dep)))))))))
 446
 447 (test-equal "options->transformation, with-commit + with-patch"
 448   '(#t #t)
 449   (let* ((patch  (search-patch "glibc-locales.patch"))
 450          (commit "f8934ec94df5868ee8baf1fb0f8ed0f24e7e91eb")
 451          (t      (options->transformation
 452                   ;; Note: options are applied in reverse order, so
 453                   ;; 'with-patch' comes on top.
 454                   `((with-patch . ,(string-append "guile-gcrypt=" patch))
 455                     (with-commit
 456                      . ,(string-append "guile-gcrypt=" commit))))))
 457     (let ((new (t (@ (gnu packages gnupg) guile-gcrypt))))
 458       (match (package-source new)
 459         ((? computed-file? source)
 460          (let* ((gexp   (computed-file-gexp source))
 461                 (inputs (map gexp-input-thing
 462                              ((@@ (guix gexp) gexp-inputs) gexp))))
 463            (list (any (lambda (input)
 464                         (and (git-checkout? input)
 465                              (string=? commit (git-checkout-commit input))))
 466                       inputs)
 467                  (any (lambda (input)
 468                         (and (local-file? input)
 469                              (string=? (local-file-file input) patch)))
 470                       inputs))))))))
 471
 472 (test-equal "options->transformation, property order"
 473   ;; See <https://issues.guix.gnu.org/54942>.
 474   '((with-debug-info . "does-not-exist")
 475     (with-commit . "does-not-exist=aaaaaaa")
 476     (without-tests . "does-not-exist"))
 477   (let* ((t (options->transformation
 478              '((with-debug-info . "does-not-exist")
 479                (with-commit . "does-not-exist=aaaaaaa")
 480                (without-tests . "does-not-exist")))))
 481     (let ((new (t coreutils)))
 482       (assq-ref (package-properties new) 'transformations))))
 483
 484 (test-equal "options->transformation, with-latest"
 485   "42.0"
 486   (mock ((guix upstream) %updaters
 487          (delay (list (upstream-updater
 488                        (name 'dummy)
 489                        (pred (const #t))
 490                        (description "")
 491                        (latest (const (upstream-source
 492                                        (package "foo")
 493                                        (version "42.0")
 494                                        (urls '("http://example.org")))))))))
 495         (let* ((p (dummy-package "foo" (version "1.0")))
 496                (t (options->transformation
 497                    `((with-latest . "foo")))))
 498           (package-version (t p)))))
 499
 500 (test-equal "options->transformation, tune"
 501   '(cpu-tuning . "superfast")
 502   (let* ((p0 (dummy-package "p0"))
 503          (p1 (dummy-package "p1"
 504                (inputs `(("p0" ,p0)))
 505                (properties '((tunable? . #t)))))
 506          (p2 (dummy-package "p2"
 507                (inputs `(("p1" ,p1)))))
 508          (t  (options->transformation '((tune . "superfast"))))
 509          (p3 (t p2)))
 510     (and (not (package-replacement p3))
 511          (match (package-inputs p3)
 512            ((("p1" tuned))
 513             (match (package-inputs tuned)
 514               ((("p0" p0))
 515                (and (not (package-replacement p0))
 516                     (assq 'cpu-tuning
 517                           (package-properties
 518                            (package-replacement tuned)))))))))))
 519
 520 (test-assert "options->transformations, tune, wrong micro-architecture"
 521   (let ((p (dummy-package "tunable"
 522              (properties '((tunable? . #t)))))
 523         (t (options->transformation '((tune . "nonexistent-superfast")))))
 524     ;; Because GCC used by P's build system does not support
 525     ;; '-march=nonexistent-superfast', we should see an error when lowering
 526     ;; the tuned package.
 527     (guard (c ((formatted-message? c)
 528                (member "nonexistent-superfast"
 529                        (formatted-message-arguments c))))
 530       (package->bag (t p))
 531       #f)))
 532
 533 (test-equal "options->transformation + package->manifest-entry"
 534   '((transformations . ((without-tests . "foo"))))
 535   (let* ((p (dummy-package "foo"))
 536          (t (options->transformation '((without-tests . "foo"))))
 537          (e (package->manifest-entry (t p))))
 538     (manifest-entry-properties e)))
 539
 540 (test-end)
 541
 542 ;;; Local Variables:
 543 ;;; eval: (put 'dummy-package 'scheme-indent-function 1)
 544 ;;; End: