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   ;; When a transformation in not applicable, a warning must be raised.
 107   (let* ((p (dummy-package "foobar"))
 108          (s (search-path %load-path "guix.scm"))
 109          (t (options->transformation `((with-source . ,s)))))
 110     (let* ((port (open-output-string))
 111            (new  (parameterize ((guix-warning-port port))
 112                    (t p))))
 113       (and (eq? new p)
 114            (string-contains (get-output-string port)
 115                             "had no effect")))))
 116
 117 (test-assert "options->transformation, with-source, PKG=URI"
 118   (let* ((p (dummy-package "foo"))
 119          (s (search-path %load-path "guix.scm"))
 120          (f (string-append "foo=" s))
 121          (t (options->transformation `((with-source . ,f)))))
 122     (with-store store
 123       (let* ((new (t p))
 124              (source (run-with-store store
 125                        (lower-object (package-source new)))))
 126         (and (not (eq? new p))
 127              (string=? (package-name new) (package-name p))
 128              (string=? (package-version new)
 129                        (package-version p))
 130              (string=? source
 131                        (add-to-store store (basename s) #t
 132                                      "sha256" s)))))))
 133
 134 (test-assert "options->transformation, with-source, PKG@VER=URI"
 135   (let* ((p (dummy-package "foo"))
 136          (s (search-path %load-path "guix.scm"))
 137          (f (string-append "foo@42.0=" s))
 138          (t (options->transformation `((with-source . ,f)))))
 139     (with-store store
 140       (let* ((new (t p))
 141              (source (run-with-store store
 142                        (lower-object (package-source new)))))
 143         (and (not (eq? new p))
 144              (string=? (package-name new) (package-name p))
 145              (string=? (package-version new) "42.0")
 146              (string=? source
 147                        (add-to-store store (basename s) #t
 148                                      "sha256" s)))))))
 149
 150 (test-assert "options->transformation, with-input"
 151   (let* ((p (dummy-package "guix.scm"
 152               (inputs `(("foo" ,(specification->package "coreutils"))
 153                         ("bar" ,(specification->package "grep"))
 154                         ("baz" ,(dummy-package "chbouib"
 155                                   (native-inputs `(("x" ,grep)))))))))
 156          (t (options->transformation '((with-input . "coreutils=busybox")
 157                                        (with-input . "grep=findutils")))))
 158     (let ((new (t p)))
 159       (and (not (eq? new p))
 160            (match (package-inputs new)
 161              ((("foo" dep1) ("bar" dep2) ("baz" dep3))
 162               (and (string=? (package-full-name dep1)
 163                              (package-full-name busybox))
 164                    (string=? (package-full-name dep2)
 165                              (package-full-name findutils))
 166                    (string=? (package-name dep3) "chbouib")
 167                    (match (package-native-inputs dep3)
 168                      ((("x" dep))
 169                       (string=? (package-full-name dep)
 170                                 (package-full-name findutils)))))))))))
 171
 172 (test-assert "options->transformation, with-graft"
 173   (let* ((p (dummy-package "guix.scm"
 174               (inputs `(("foo" ,grep)
 175                         ("bar" ,(dummy-package "chbouib"
 176                                   (native-inputs `(("x" ,grep)))))))))
 177          (t (options->transformation '((with-graft . "grep=findutils")))))
 178     (let ((new (t p)))
 179       (and (not (eq? new p))
 180            (match (package-inputs new)
 181              ((("foo" dep1) ("bar" dep2))
 182               (and (string=? (package-full-name dep1)
 183                              (package-full-name grep))
 184                    (string=? (package-full-name (package-replacement dep1))
 185                              (package-full-name findutils))
 186                    (string=? (package-name dep2) "chbouib")
 187                    (match (package-native-inputs dep2)
 188                      ((("x" dep))
 189                       (with-store store
 190                         (string=? (derivation-file-name
 191                                    (package-derivation store findutils))
 192                                   (derivation-file-name
 193                                    (package-derivation store dep)))))))))))))
 194
 195 (test-equal "options->transformation, with-branch"
 196   (git-checkout (url "https://example.org")
 197                 (branch "devel")
 198                 (recursive? #t))
 199   (let* ((p (dummy-package "guix.scm"
 200               (inputs `(("foo" ,grep)
 201                         ("bar" ,(dummy-package "chbouib"
 202                                   (source (origin
 203                                             (method git-fetch)
 204                                             (uri (git-reference
 205                                                   (url "https://example.org")
 206                                                   (commit "cabba9e")))
 207                                             (sha256 #f)))))))))
 208          (t (options->transformation '((with-branch . "chbouib=devel")))))
 209     (let ((new (t p)))
 210       (and (not (eq? new p))
 211            (match (package-inputs new)
 212              ((("foo" dep1) ("bar" dep2))
 213               (and (string=? (package-full-name dep1)
 214                              (package-full-name grep))
 215                    (string=? (package-name dep2) "chbouib")
 216                    (package-source dep2))))))))
 217
 218 (test-equal "options->transformation, with-commit"
 219   (git-checkout (url "https://example.org")
 220                 (commit "abcdef")
 221                 (recursive? #t))
 222   (let* ((p (dummy-package "guix.scm"
 223               (inputs `(("foo" ,grep)
 224                         ("bar" ,(dummy-package "chbouib"
 225                                   (source (origin
 226                                             (method git-fetch)
 227                                             (uri (git-reference
 228                                                   (url "https://example.org")
 229                                                   (commit "cabba9e")))
 230                                             (sha256 #f)))))))))
 231          (t (options->transformation '((with-commit . "chbouib=abcdef")))))
 232     (let ((new (t p)))
 233       (and (not (eq? new p))
 234            (match (package-inputs new)
 235              ((("foo" dep1) ("bar" dep2))
 236               (and (string=? (package-full-name dep1)
 237                              (package-full-name grep))
 238                    (string=? (package-name dep2) "chbouib")
 239                    (package-source dep2))))))))
 240
 241 (test-equal "options->transformation, with-commit, version transformation"
 242   '("1.0" "1.0-rc1-2-gabc123" "git.abc123")
 243   (map (lambda (commit)
 244          (let* ((p (dummy-package "guix.scm"
 245                      (inputs `(("foo" ,(dummy-package "chbouib"
 246                                          (source (origin
 247                                                    (method git-fetch)
 248                                                    (uri (git-reference
 249                                                          (url "https://example.org")
 250                                                          (commit "cabba9e")))
 251                                                    (sha256 #f)))))))))
 252                 (t (options->transformation
 253                     `((with-commit . ,(string-append "chbouib=" commit))))))
 254            (let ((new (t p)))
 255              (and (not (eq? new p))
 256                   (match (package-inputs new)
 257                     ((("foo" dep1))
 258                      (package-version dep1)))))))
 259        '("v1.0" "1.0-rc1-2-gabc123" "abc123")))
 260
 261 (test-equal "options->transformation, with-git-url"
 262   (let ((source (git-checkout (url "https://example.org")
 263                               (recursive? #t))))
 264     (list source source))
 265   (let* ((p (dummy-package "guix.scm"
 266               (inputs `(("foo" ,grep)
 267                         ("bar" ,(dummy-package "chbouib"
 268                                   (native-inputs `(("x" ,grep)))))))))
 269          (t (options->transformation '((with-git-url . "grep=https://example.org")))))
 270     (let ((new (t p)))
 271       (and (not (eq? new p))
 272            (match (package-inputs new)
 273              ((("foo" dep1) ("bar" dep2))
 274               (and (string=? (package-full-name dep1)
 275                              (package-full-name grep))
 276                    (string=? (package-name dep2) "chbouib")
 277                    (match (package-native-inputs dep2)
 278                      ((("x" dep3))
 279                       (map package-source (list dep1 dep3)))))))))))
 280
 281 (test-equal "options->transformation, with-git-url + with-branch"
 282   ;; Combine the two options and make sure the 'with-branch' transformation
 283   ;; comes after the 'with-git-url' transformation.
 284   (let ((source (git-checkout (url "https://example.org")
 285                               (branch "BRANCH")
 286                               (recursive? #t))))
 287     (list source source))
 288   (let* ((p (dummy-package "guix.scm"
 289               (inputs `(("foo" ,grep)
 290                         ("bar" ,(dummy-package "chbouib"
 291                                   (native-inputs `(("x" ,grep)))))))))
 292          (t (options->transformation
 293              (reverse '((with-git-url
 294                          . "grep=https://example.org")
 295                         (with-branch . "grep=BRANCH"))))))
 296     (let ((new (t p)))
 297       (and (not (eq? new p))
 298            (match (package-inputs new)
 299              ((("foo" dep1) ("bar" dep2))
 300               (and (string=? (package-name dep1) "grep")
 301                    (string=? (package-name dep2) "chbouib")
 302                    (match (package-native-inputs dep2)
 303                      ((("x" dep3))
 304                       (map package-source (list dep1 dep3)))))))))))
 305
 306 (define* (depends-on-toolchain? p #:optional (toolchain "gcc-toolchain"))
 307   "Return true if P depends on TOOLCHAIN instead of the default tool chain."
 308   (define toolchain-packages
 309     '("gcc" "binutils" "glibc" "ld-wrapper"))
 310
 311   (define (package-name* obj)
 312     (and (package? obj) (package-name obj)))
 313
 314   (match (bag-build-inputs (package->bag p))
 315     (((_ (= package-name* packages) . _) ...)
 316      (and (not (any (cut member <> packages) toolchain-packages))
 317           (member toolchain packages)))))
 318
 319 (test-assert "options->transformation, with-c-toolchain"
 320   (let* ((dep0 (dummy-package "chbouib"
 321                  (build-system gnu-build-system)
 322                  (native-inputs `(("y" ,grep)))))
 323          (dep1 (dummy-package "stuff"
 324                  (native-inputs `(("x" ,dep0)))))
 325          (p    (dummy-package "thingie"
 326                  (build-system gnu-build-system)
 327                  (inputs `(("foo" ,grep)
 328                            ("bar" ,dep1)))))
 329          (t    (options->transformation
 330                 '((with-c-toolchain . "chbouib=gcc-toolchain")))))
 331     ;; Here we check that the transformation applies to DEP0 and all its
 332     ;; dependents: DEP0 must use GCC-TOOLCHAIN, DEP1 must use GCC-TOOLCHAIN
 333     ;; and the DEP0 that uses GCC-TOOLCHAIN, and so on.
 334     (let ((new (t p)))
 335       (and (depends-on-toolchain? new "gcc-toolchain")
 336            (match (bag-build-inputs (package->bag new))
 337              ((("foo" dep0) ("bar" dep1) _ ...)
 338               (and (depends-on-toolchain? dep1 "gcc-toolchain")
 339                    (not (depends-on-toolchain? dep0 "gcc-toolchain"))
 340                    (string=? (package-full-name dep0)
 341                              (package-full-name grep))
 342                    (match (bag-build-inputs (package->bag dep1))
 343                      ((("x" dep) _ ...)
 344                       (and (depends-on-toolchain? dep "gcc-toolchain")
 345                            (match (bag-build-inputs (package->bag dep))
 346                              ((("y" dep) _ ...)   ;this one is unchanged
 347                               (eq? dep grep)))))))))))))
 348
 349 (test-equal "options->transformation, with-c-toolchain twice"
 350   (package-full-name grep)
 351   (let* ((dep0 (dummy-package "chbouib"))
 352          (dep1 (dummy-package "stuff"))
 353          (p    (dummy-package "thingie"
 354                  (build-system gnu-build-system)
 355                  (inputs `(("foo" ,dep0)
 356                            ("bar" ,dep1)
 357                            ("baz" ,grep)))))
 358          (t    (options->transformation
 359                 '((with-c-toolchain . "chbouib=clang-toolchain")
 360                   (with-c-toolchain . "stuff=clang-toolchain")))))
 361     (let ((new (t p)))
 362       (and (depends-on-toolchain? new "clang-toolchain")
 363            (match (bag-build-inputs (package->bag new))
 364              ((("foo" dep0) ("bar" dep1) ("baz" dep2) _ ...)
 365               (and (depends-on-toolchain? dep0 "clang-toolchain")
 366                    (depends-on-toolchain? dep1 "clang-toolchain")
 367                    (not (depends-on-toolchain? dep2 "clang-toolchain"))
 368                    (package-full-name dep2))))))))
 369
 370 (test-assert "options->transformation, with-c-toolchain, no effect"
 371   (let ((p (dummy-package "thingie"))
 372         (t (options->transformation
 373             '((with-c-toolchain . "does-not-exist=gcc-toolchain")))))
 374     ;; When it has no effect, '--with-c-toolchain' returns P.
 375     (eq? (t p) p)))
 376
 377 (test-equal "options->transformation, with-debug-info"
 378   '(#:strip-binaries? #f)
 379   (let* ((dep  (dummy-package "chbouib"))
 380          (p    (dummy-package "thingie"
 381                  (build-system gnu-build-system)
 382                  (inputs `(("foo" ,dep)
 383                            ("bar" ,grep)))))
 384          (t    (options->transformation
 385                 '((with-debug-info . "chbouib")))))
 386     (let ((new (t p)))
 387       (match (package-inputs new)
 388         ((("foo" dep0) ("bar" dep1))
 389          (and (string=? (package-full-name dep1)
 390                         (package-full-name grep))
 391               (package-arguments (package-replacement dep0))))))))
 392
 393 (test-assert "options->transformation, without-tests"
 394   (let* ((dep (dummy-package "dep"))
 395          (p   (dummy-package "foo"
 396                 (inputs `(("dep" ,dep)))))
 397          (t   (options->transformation '((without-tests . "dep")
 398                                          (without-tests . "tar")))))
 399     (let ((new (t p)))
 400       (match (bag-direct-inputs (package->bag new))
 401         ((("dep" dep) ("tar" tar) _ ...)
 402          (and (equal? (package-arguments dep) '(#:tests? #f))
 403               (match (memq #:tests? (package-arguments tar))
 404                 ((#:tests? #f _ ...) #t))))))))
 405
 406 (test-equal "options->transformation, with-patch"
 407   (search-patches "glibc-locales.patch" "guile-relocatable.patch")
 408   (let* ((dep    (dummy-package "dep"
 409                    (source (dummy-origin))))
 410          (p      (dummy-package "foo"
 411                    (inputs `(("dep" ,dep)))))
 412          (patch1 (search-patch "glibc-locales.patch"))
 413          (patch2 (search-patch "guile-relocatable.patch"))
 414          (t      (options->transformation
 415                   `((with-patch . ,(string-append "dep=" patch1))
 416                     (with-patch . ,(string-append "dep=" patch2))
 417                     (with-patch . ,(string-append "tar=" patch1))))))
 418     (let ((new (t p)))
 419       (match (bag-direct-inputs (package->bag new))
 420         ((("dep" dep) ("tar" tar) _ ...)
 421          (and (member patch1
 422                       (filter-map (lambda (patch)
 423                                     (and (local-file? patch)
 424                                          (local-file-file patch)))
 425                                   (origin-patches (package-source tar))))
 426               (map local-file-file
 427                    (origin-patches (package-source dep)))))))))
 428
 429 (test-equal "options->transformation, with-commit + with-patch"
 430   '(#t #t)
 431   (let* ((patch  (search-patch "glibc-locales.patch"))
 432          (commit "f8934ec94df5868ee8baf1fb0f8ed0f24e7e91eb")
 433          (t      (options->transformation
 434                   ;; Note: options are applied in reverse order, so
 435                   ;; 'with-patch' comes on top.
 436                   `((with-patch . ,(string-append "guile-gcrypt=" patch))
 437                     (with-commit
 438                      . ,(string-append "guile-gcrypt=" commit))))))
 439     (let ((new (t (@ (gnu packages gnupg) guile-gcrypt))))
 440       (match (package-source new)
 441         ((? computed-file? source)
 442          (let* ((gexp   (computed-file-gexp source))
 443                 (inputs (map gexp-input-thing
 444                              ((@@ (guix gexp) gexp-inputs) gexp))))
 445            (list (any (lambda (input)
 446                         (and (git-checkout? input)
 447                              (string=? commit (git-checkout-commit input))))
 448                       inputs)
 449                  (any (lambda (input)
 450                         (and (local-file? input)
 451                              (string=? (local-file-file input) patch)))
 452                       inputs))))))))
 453
 454 (test-equal "options->transformation, property order"
 455   ;; See <https://issues.guix.gnu.org/54942>.
 456   '((with-debug-info . "does-not-exist")
 457     (with-commit . "does-not-exist=aaaaaaa")
 458     (without-tests . "does-not-exist"))
 459   (let* ((t (options->transformation
 460              '((with-debug-info . "does-not-exist")
 461                (with-commit . "does-not-exist=aaaaaaa")
 462                (without-tests . "does-not-exist")))))
 463     (let ((new (t coreutils)))
 464       (assq-ref (package-properties new) 'transformations))))
 465
 466 (test-equal "options->transformation, with-latest"
 467   "42.0"
 468   (mock ((guix upstream) %updaters
 469          (delay (list (upstream-updater
 470                        (name 'dummy)
 471                        (pred (const #t))
 472                        (description "")
 473                        (latest (const (upstream-source
 474                                        (package "foo")
 475                                        (version "42.0")
 476                                        (urls '("http://example.org")))))))))
 477         (let* ((p (dummy-package "foo" (version "1.0")))
 478                (t (options->transformation
 479                    `((with-latest . "foo")))))
 480           (package-version (t p)))))
 481
 482 (test-equal "options->transformation, tune"
 483   '(cpu-tuning . "superfast")
 484   (let* ((p0 (dummy-package "p0"))
 485          (p1 (dummy-package "p1"
 486                (inputs `(("p0" ,p0)))
 487                (properties '((tunable? . #t)))))
 488          (p2 (dummy-package "p2"
 489                (inputs `(("p1" ,p1)))))
 490          (t  (options->transformation '((tune . "superfast"))))
 491          (p3 (t p2)))
 492     (and (not (package-replacement p3))
 493          (match (package-inputs p3)
 494            ((("p1" tuned))
 495             (match (package-inputs tuned)
 496               ((("p0" p0))
 497                (and (not (package-replacement p0))
 498                     (assq 'cpu-tuning
 499                           (package-properties
 500                            (package-replacement tuned)))))))))))
 501
 502 (test-assert "options->transformations, tune, wrong micro-architecture"
 503   (let ((p (dummy-package "tunable"
 504              (properties '((tunable? . #t)))))
 505         (t (options->transformation '((tune . "nonexistent-superfast")))))
 506     ;; Because GCC used by P's build system does not support
 507     ;; '-march=nonexistent-superfast', we should see an error when lowering
 508     ;; the tuned package.
 509     (guard (c ((formatted-message? c)
 510                (member "nonexistent-superfast"
 511                        (formatted-message-arguments c))))
 512       (package->bag (t p))
 513       #f)))
 514
 515 (test-equal "options->transformation + package->manifest-entry"
 516   '((transformations . ((without-tests . "foo"))))
 517   (let* ((p (dummy-package "foo"))
 518          (t (options->transformation '((without-tests . "foo"))))
 519          (e (package->manifest-entry (t p))))
 520     (manifest-entry-properties e)))
 521
 522 (test-end)
 523
 524 ;;; Local Variables:
 525 ;;; eval: (put 'dummy-package 'scheme-indent-function 1)
 526 ;;; End: