tests/transformations.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016, 2017, 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 (test-transformations)
  20   #:use-module (guix tests)
  21   #:use-module (guix store)
  22   #:use-module ((guix gexp) #:select (lower-object))
  23   #:use-module (guix derivations)
  24   #:use-module (guix packages)
  25   #:use-module (guix git-download)
  26   #:use-module (guix build-system)
  27   #:use-module (guix build-system gnu)
  28   #:use-module (guix transformations)
  29   #:use-module (guix ui)
  30   #:use-module (guix utils)
  31   #:use-module (guix git)
  32   #:use-module (gnu packages)
  33   #:use-module (gnu packages base)
  34   #:use-module (gnu packages busybox)
  35   #:use-module (ice-9 match)
  36   #:use-module (srfi srfi-1)
  37   #:use-module (srfi srfi-26)
  38   #:use-module (srfi srfi-64))
  39
  40 \f
  41 (test-begin "transformations")
  42
  43 (test-assert "options->transformation, no transformations"
  44   (let ((p (dummy-package "foo"))
  45         (t (options->transformation '())))
  46     (eq? (t p) p)))
  47
  48 (test-assert "options->transformation, with-source"
  49   ;; Our pseudo-package is called 'guix.scm' so the 'guix.scm' source should
  50   ;; be applicable.
  51   (let* ((p (dummy-package "guix.scm"))
  52          (s (search-path %load-path "guix.scm"))
  53          (t (options->transformation `((with-source . ,s)))))
  54     (with-store store
  55       (let* ((new (t p))
  56              (source (run-with-store store
  57                        (lower-object (package-source new)))))
  58         (and (not (eq? new p))
  59              (string=? source
  60                        (add-to-store store "guix.scm" #t
  61                                      "sha256" s)))))))
  62
  63 (test-assert "options->transformation, with-source, replacement"
  64   ;; Same, but this time the original package has a 'replacement' field.  We
  65   ;; expect that replacement to be set to #f in the new package.
  66   (let* ((p (dummy-package "guix.scm" (replacement coreutils)))
  67          (s (search-path %load-path "guix.scm"))
  68          (t (options->transformation `((with-source . ,s)))))
  69     (let ((new (t p)))
  70       (and (not (eq? new p))
  71            (not (package-replacement new))))))
  72
  73 (test-assert "options->transformation, with-source, with version"
  74   ;; Our pseudo-package is called 'guix.scm' so the 'guix.scm-2.0' source
  75   ;; should be applicable, and its version should be extracted.
  76   (let ((p (dummy-package "foo"))
  77         (s (search-path %load-path "guix.scm")))
  78     (call-with-temporary-directory
  79      (lambda (directory)
  80        (let* ((f (string-append directory "/foo-42.0.tar.gz"))
  81               (t (options->transformation `((with-source . ,f)))))
  82          (copy-file s f)
  83          (with-store store
  84            (let* ((new (t p))
  85                   (source (run-with-store store
  86                             (lower-object (package-source new)))))
  87              (and (not (eq? new p))
  88                   (string=? (package-name new) (package-name p))
  89                   (string=? (package-version new) "42.0")
  90                   (string=? source
  91                             (add-to-store store (basename f) #t
  92                                           "sha256" f))))))))))
  93
  94 (test-assert "options->transformation, with-source, no matches"
  95   ;; When a transformation in not applicable, a warning must be raised.
  96   (let* ((p (dummy-package "foobar"))
  97          (s (search-path %load-path "guix.scm"))
  98          (t (options->transformation `((with-source . ,s)))))
  99     (let* ((port (open-output-string))
 100            (new  (parameterize ((guix-warning-port port))
 101                    (t p))))
 102       (and (eq? new p)
 103            (string-contains (get-output-string port)
 104                             "had no effect")))))
 105
 106 (test-assert "options->transformation, with-source, PKG=URI"
 107   (let* ((p (dummy-package "foo"))
 108          (s (search-path %load-path "guix.scm"))
 109          (f (string-append "foo=" s))
 110          (t (options->transformation `((with-source . ,f)))))
 111     (with-store store
 112       (let* ((new (t p))
 113              (source (run-with-store store
 114                        (lower-object (package-source new)))))
 115         (and (not (eq? new p))
 116              (string=? (package-name new) (package-name p))
 117              (string=? (package-version new)
 118                        (package-version p))
 119              (string=? source
 120                        (add-to-store store (basename s) #t
 121                                      "sha256" s)))))))
 122
 123 (test-assert "options->transformation, with-source, PKG@VER=URI"
 124   (let* ((p (dummy-package "foo"))
 125          (s (search-path %load-path "guix.scm"))
 126          (f (string-append "foo@42.0=" s))
 127          (t (options->transformation `((with-source . ,f)))))
 128     (with-store store
 129       (let* ((new (t p))
 130              (source (run-with-store store
 131                        (lower-object (package-source new)))))
 132         (and (not (eq? new p))
 133              (string=? (package-name new) (package-name p))
 134              (string=? (package-version new) "42.0")
 135              (string=? source
 136                        (add-to-store store (basename s) #t
 137                                      "sha256" s)))))))
 138
 139 (test-assert "options->transformation, with-input"
 140   (let* ((p (dummy-package "guix.scm"
 141               (inputs `(("foo" ,(specification->package "coreutils"))
 142                         ("bar" ,(specification->package "grep"))
 143                         ("baz" ,(dummy-package "chbouib"
 144                                   (native-inputs `(("x" ,grep)))))))))
 145          (t (options->transformation '((with-input . "coreutils=busybox")
 146                                        (with-input . "grep=findutils")))))
 147     (let ((new (t p)))
 148       (and (not (eq? new p))
 149            (match (package-inputs new)
 150              ((("foo" dep1) ("bar" dep2) ("baz" dep3))
 151               (and (string=? (package-full-name dep1)
 152                              (package-full-name busybox))
 153                    (string=? (package-full-name dep2)
 154                              (package-full-name findutils))
 155                    (string=? (package-name dep3) "chbouib")
 156                    (match (package-native-inputs dep3)
 157                      ((("x" dep))
 158                       (string=? (package-full-name dep)
 159                                 (package-full-name findutils)))))))))))
 160
 161 (test-assert "options->transformation, with-graft"
 162   (let* ((p (dummy-package "guix.scm"
 163               (inputs `(("foo" ,grep)
 164                         ("bar" ,(dummy-package "chbouib"
 165                                   (native-inputs `(("x" ,grep)))))))))
 166          (t (options->transformation '((with-graft . "grep=findutils")))))
 167     (let ((new (t p)))
 168       (and (not (eq? new p))
 169            (match (package-inputs new)
 170              ((("foo" dep1) ("bar" dep2))
 171               (and (string=? (package-full-name dep1)
 172                              (package-full-name grep))
 173                    (string=? (package-full-name (package-replacement dep1))
 174                              (package-full-name findutils))
 175                    (string=? (package-name dep2) "chbouib")
 176                    (match (package-native-inputs dep2)
 177                      ((("x" dep))
 178                       (with-store store
 179                         (string=? (derivation-file-name
 180                                    (package-derivation store findutils))
 181                                   (derivation-file-name
 182                                    (package-derivation store dep)))))))))))))
 183
 184 (test-equal "options->transformation, with-branch"
 185   (git-checkout (url "https://example.org")
 186                 (branch "devel")
 187                 (recursive? #t))
 188   (let* ((p (dummy-package "guix.scm"
 189               (inputs `(("foo" ,grep)
 190                         ("bar" ,(dummy-package "chbouib"
 191                                   (source (origin
 192                                             (method git-fetch)
 193                                             (uri (git-reference
 194                                                   (url "https://example.org")
 195                                                   (commit "cabba9e")))
 196                                             (sha256 #f)))))))))
 197          (t (options->transformation '((with-branch . "chbouib=devel")))))
 198     (let ((new (t p)))
 199       (and (not (eq? new p))
 200            (match (package-inputs new)
 201              ((("foo" dep1) ("bar" dep2))
 202               (and (string=? (package-full-name dep1)
 203                              (package-full-name grep))
 204                    (string=? (package-name dep2) "chbouib")
 205                    (package-source dep2))))))))
 206
 207 (test-equal "options->transformation, with-commit"
 208   (git-checkout (url "https://example.org")
 209                 (commit "abcdef")
 210                 (recursive? #t))
 211   (let* ((p (dummy-package "guix.scm"
 212               (inputs `(("foo" ,grep)
 213                         ("bar" ,(dummy-package "chbouib"
 214                                   (source (origin
 215                                             (method git-fetch)
 216                                             (uri (git-reference
 217                                                   (url "https://example.org")
 218                                                   (commit "cabba9e")))
 219                                             (sha256 #f)))))))))
 220          (t (options->transformation '((with-commit . "chbouib=abcdef")))))
 221     (let ((new (t p)))
 222       (and (not (eq? new p))
 223            (match (package-inputs new)
 224              ((("foo" dep1) ("bar" dep2))
 225               (and (string=? (package-full-name dep1)
 226                              (package-full-name grep))
 227                    (string=? (package-name dep2) "chbouib")
 228                    (package-source dep2))))))))
 229
 230 (test-equal "options->transformation, with-git-url"
 231   (let ((source (git-checkout (url "https://example.org")
 232                               (recursive? #t))))
 233     (list source source))
 234   (let* ((p (dummy-package "guix.scm"
 235               (inputs `(("foo" ,grep)
 236                         ("bar" ,(dummy-package "chbouib"
 237                                   (native-inputs `(("x" ,grep)))))))))
 238          (t (options->transformation '((with-git-url . "grep=https://example.org")))))
 239     (let ((new (t p)))
 240       (and (not (eq? new p))
 241            (match (package-inputs new)
 242              ((("foo" dep1) ("bar" dep2))
 243               (and (string=? (package-full-name dep1)
 244                              (package-full-name grep))
 245                    (string=? (package-name dep2) "chbouib")
 246                    (match (package-native-inputs dep2)
 247                      ((("x" dep3))
 248                       (map package-source (list dep1 dep3)))))))))))
 249
 250 (test-equal "options->transformation, with-git-url + with-branch"
 251   ;; Combine the two options and make sure the 'with-branch' transformation
 252   ;; comes after the 'with-git-url' transformation.
 253   (let ((source (git-checkout (url "https://example.org")
 254                               (branch "BRANCH")
 255                               (recursive? #t))))
 256     (list source source))
 257   (let* ((p (dummy-package "guix.scm"
 258               (inputs `(("foo" ,grep)
 259                         ("bar" ,(dummy-package "chbouib"
 260                                   (native-inputs `(("x" ,grep)))))))))
 261          (t (options->transformation
 262              (reverse '((with-git-url
 263                          . "grep=https://example.org")
 264                         (with-branch . "grep=BRANCH"))))))
 265     (let ((new (t p)))
 266       (and (not (eq? new p))
 267            (match (package-inputs new)
 268              ((("foo" dep1) ("bar" dep2))
 269               (and (string=? (package-name dep1) "grep")
 270                    (string=? (package-name dep2) "chbouib")
 271                    (match (package-native-inputs dep2)
 272                      ((("x" dep3))
 273                       (map package-source (list dep1 dep3)))))))))))
 274
 275 (define* (depends-on-toolchain? p #:optional (toolchain "gcc-toolchain"))
 276   "Return true if P depends on TOOLCHAIN instead of the default tool chain."
 277   (define toolchain-packages
 278     '("gcc" "binutils" "glibc" "ld-wrapper"))
 279
 280   (define (package-name* obj)
 281     (and (package? obj) (package-name obj)))
 282
 283   (match (bag-build-inputs (package->bag p))
 284     (((_ (= package-name* packages) . _) ...)
 285      (and (not (any (cut member <> packages) toolchain-packages))
 286           (member toolchain packages)))))
 287
 288 (test-assert "options->transformation, with-c-toolchain"
 289   (let* ((dep0 (dummy-package "chbouib"
 290                  (build-system gnu-build-system)
 291                  (native-inputs `(("y" ,grep)))))
 292          (dep1 (dummy-package "stuff"
 293                  (native-inputs `(("x" ,dep0)))))
 294          (p    (dummy-package "thingie"
 295                  (build-system gnu-build-system)
 296                  (inputs `(("foo" ,grep)
 297                            ("bar" ,dep1)))))
 298          (t    (options->transformation
 299                 '((with-c-toolchain . "chbouib=gcc-toolchain")))))
 300     ;; Here we check that the transformation applies to DEP0 and all its
 301     ;; dependents: DEP0 must use GCC-TOOLCHAIN, DEP1 must use GCC-TOOLCHAIN
 302     ;; and the DEP0 that uses GCC-TOOLCHAIN, and so on.
 303     (let ((new (t p)))
 304       (and (depends-on-toolchain? new "gcc-toolchain")
 305            (match (bag-build-inputs (package->bag new))
 306              ((("foo" dep0) ("bar" dep1) _ ...)
 307               (and (depends-on-toolchain? dep1 "gcc-toolchain")
 308                    (not (depends-on-toolchain? dep0 "gcc-toolchain"))
 309                    (string=? (package-full-name dep0)
 310                              (package-full-name grep))
 311                    (match (bag-build-inputs (package->bag dep1))
 312                      ((("x" dep) _ ...)
 313                       (and (depends-on-toolchain? dep "gcc-toolchain")
 314                            (match (bag-build-inputs (package->bag dep))
 315                              ((("y" dep) _ ...)   ;this one is unchanged
 316                               (eq? dep grep)))))))))))))
 317
 318 (test-equal "options->transformation, with-c-toolchain twice"
 319   (package-full-name grep)
 320   (let* ((dep0 (dummy-package "chbouib"))
 321          (dep1 (dummy-package "stuff"))
 322          (p    (dummy-package "thingie"
 323                  (build-system gnu-build-system)
 324                  (inputs `(("foo" ,dep0)
 325                            ("bar" ,dep1)
 326                            ("baz" ,grep)))))
 327          (t    (options->transformation
 328                 '((with-c-toolchain . "chbouib=clang-toolchain")
 329                   (with-c-toolchain . "stuff=clang-toolchain")))))
 330     (let ((new (t p)))
 331       (and (depends-on-toolchain? new "clang-toolchain")
 332            (match (bag-build-inputs (package->bag new))
 333              ((("foo" dep0) ("bar" dep1) ("baz" dep2) _ ...)
 334               (and (depends-on-toolchain? dep0 "clang-toolchain")
 335                    (depends-on-toolchain? dep1 "clang-toolchain")
 336                    (not (depends-on-toolchain? dep2 "clang-toolchain"))
 337                    (package-full-name dep2))))))))
 338
 339 (test-assert "options->transformation, with-c-toolchain, no effect"
 340   (let ((p (dummy-package "thingie"))
 341         (t (options->transformation
 342             '((with-c-toolchain . "does-not-exist=gcc-toolchain")))))
 343     ;; When it has no effect, '--with-c-toolchain' returns P.
 344     (eq? (t p) p)))
 345
 346 (test-equal "options->transformation, with-debug-info"
 347   '(#:strip-binaries? #f)
 348   (let* ((dep  (dummy-package "chbouib"))
 349          (p    (dummy-package "thingie"
 350                  (build-system gnu-build-system)
 351                  (inputs `(("foo" ,dep)
 352                            ("bar" ,grep)))))
 353          (t    (options->transformation
 354                 '((with-debug-info . "chbouib")))))
 355     (let ((new (t p)))
 356       (match (package-inputs new)
 357         ((("foo" dep0) ("bar" dep1))
 358          (and (string=? (package-full-name dep1)
 359                         (package-full-name grep))
 360               (package-arguments (package-replacement dep0))))))))
 361
 362 (test-assert "options->transformation, without-tests"
 363   (let* ((dep (dummy-package "dep"))
 364          (p   (dummy-package "foo"
 365                 (inputs `(("dep" ,dep)))))
 366          (t   (options->transformation '((without-tests . "dep")
 367                                          (without-tests . "tar")))))
 368     (let ((new (t p)))
 369       (match (bag-direct-inputs (package->bag new))
 370         ((("dep" dep) ("tar" tar) _ ...)
 371          ;; TODO: Check whether TAR has #:tests? #f when transformations
 372          ;; apply to implicit inputs.
 373          (equal? (package-arguments dep)
 374                  '(#:tests? #f)))))))
 375
 376 (test-end)
 377
 378 ;;; Local Variables:
 379 ;;; eval: (put 'dummy-package 'scheme-indent-function 1)
 380 ;;; End: