tests/grafts.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2015, 2016, 2017 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-grafts)
  20   #:use-module (guix gexp)
  21   #:use-module (guix monads)
  22   #:use-module (guix derivations)
  23   #:use-module (guix store)
  24   #:use-module (guix utils)
  25   #:use-module (guix grafts)
  26   #:use-module (guix tests)
  27   #:use-module ((gnu packages) #:select (search-bootstrap-binary))
  28   #:use-module (gnu packages bootstrap)
  29   #:use-module (srfi srfi-1)
  30   #:use-module (srfi srfi-64)
  31   #:use-module (rnrs io ports))
  32
  33 (define %store
  34   (open-connection-for-tests))
  35
  36 (define (bootstrap-binary name)
  37   (let ((bin (search-bootstrap-binary name (%current-system))))
  38     (and %store
  39          (add-to-store %store name #t "sha256" bin))))
  40
  41 (define %bash
  42   (bootstrap-binary "bash"))
  43 (define %mkdir
  44   (bootstrap-binary "mkdir"))
  45
  46 (define make-derivation-input
  47   (@@ (guix derivations) make-derivation-input))
  48
  49 \f
  50 (test-begin "grafts")
  51
  52 (test-assert "graft-derivation, grafted item is a direct dependency"
  53   (let* ((build `(begin
  54                    (mkdir %output)
  55                    (chdir %output)
  56                    (symlink %output "self")
  57                    (call-with-output-file "text"
  58                      (lambda (output)
  59                        (format output "foo/~a/bar" ,%mkdir)))
  60                    (symlink ,%bash "sh")))
  61          (orig  (build-expression->derivation %store "grafted" build
  62                                               #:inputs `(("a" ,%bash)
  63                                                          ("b" ,%mkdir))))
  64          (one   (add-text-to-store %store "bash" "fake bash"))
  65          (two   (build-expression->derivation %store "mkdir"
  66                                               '(call-with-output-file %output
  67                                                  (lambda (port)
  68                                                    (display "fake mkdir" port)))))
  69          (grafted (graft-derivation %store orig
  70                                     (list (graft
  71                                             (origin %bash)
  72                                             (replacement one))
  73                                           (graft
  74                                             (origin %mkdir)
  75                                             (replacement two))))))
  76     (and (build-derivations %store (list grafted))
  77          (let ((two     (derivation->output-path two))
  78                (grafted (derivation->output-path grafted)))
  79            (and (string=? (format #f "foo/~a/bar" two)
  80                           (call-with-input-file (string-append grafted "/text")
  81                             get-string-all))
  82                 (string=? (readlink (string-append grafted "/sh")) one)
  83                 (string=? (readlink (string-append grafted "/self"))
  84                           grafted))))))
  85
  86 (test-assert "graft-derivation, grafted item uses a different name"
  87   (let* ((build   `(begin
  88                      (mkdir %output)
  89                      (chdir %output)
  90                      (symlink %output "self")
  91                      (symlink ,%bash "sh")))
  92          (orig    (build-expression->derivation %store "grafted" build
  93                                                 #:inputs `(("a" ,%bash))))
  94          (repl    (add-text-to-store %store "BaSH" "fake bash"))
  95          (grafted (graft-derivation %store orig
  96                                     (list (graft
  97                                             (origin %bash)
  98                                             (replacement repl))))))
  99     (and (build-derivations %store (list grafted))
 100          (let ((grafted (derivation->output-path grafted)))
 101            (and (string=? (readlink (string-append grafted "/sh")) repl)
 102                 (string=? (readlink (string-append grafted "/self"))
 103                           grafted))))))
 104
 105 ;; Make sure 'derivation-file-name' always gets to see an absolute file name.
 106 (fluid-set! %file-port-name-canonicalization 'absolute)
 107
 108 (test-assert "graft-derivation, grafted item is an indirect dependency"
 109   (let* ((build `(begin
 110                    (mkdir %output)
 111                    (chdir %output)
 112                    (symlink %output "self")
 113                    (call-with-output-file "text"
 114                      (lambda (output)
 115                        (format output "foo/~a/bar" ,%mkdir)))
 116                    (symlink ,%bash "sh")))
 117          (dep   (build-expression->derivation %store "dep" build
 118                                               #:inputs `(("a" ,%bash)
 119                                                          ("b" ,%mkdir))))
 120          (orig  (build-expression->derivation %store "thing"
 121                                               '(symlink
 122                                                 (assoc-ref %build-inputs
 123                                                            "dep")
 124                                                 %output)
 125                                               #:inputs `(("dep" ,dep))))
 126          (one   (add-text-to-store %store "bash" "fake bash"))
 127          (two   (build-expression->derivation %store "mkdir"
 128                                               '(call-with-output-file %output
 129                                                  (lambda (port)
 130                                                    (display "fake mkdir" port)))))
 131          (grafted (graft-derivation %store orig
 132                                     (list (graft
 133                                             (origin %bash)
 134                                             (replacement one))
 135                                           (graft
 136                                             (origin %mkdir)
 137                                             (replacement two))))))
 138     (and (build-derivations %store (list grafted))
 139          (let* ((two     (derivation->output-path two))
 140                 (grafted (derivation->output-path grafted))
 141                 (dep     (readlink grafted)))
 142            (and (string=? (format #f "foo/~a/bar" two)
 143                           (call-with-input-file (string-append dep "/text")
 144                             get-string-all))
 145                 (string=? (readlink (string-append dep "/sh")) one)
 146                 (string=? (readlink (string-append dep "/self")) dep)
 147                 (equal? (references %store grafted) (list dep))
 148                 (lset= string=?
 149                        (list one two dep)
 150                        (references %store dep)))))))
 151
 152 (test-assert "graft-derivation, preserve empty directories"
 153   (run-with-store %store
 154     (mlet* %store-monad ((fake    (text-file "bash" "Fake bash."))
 155                          (graft -> (graft
 156                                      (origin %bash)
 157                                      (replacement fake)))
 158                          (drv     (gexp->derivation
 159                                    "to-graft"
 160                                    (with-imported-modules '((guix build utils))
 161                                      #~(begin
 162                                          (use-modules (guix build utils))
 163                                          (mkdir-p (string-append #$output
 164                                                                  "/a/b/c/d"))
 165                                          (symlink #$%bash
 166                                                   (string-append #$output
 167                                                                  "/bash"))))))
 168                          (grafted ((store-lift graft-derivation) drv
 169                                    (list graft)))
 170                          (_       (built-derivations (list grafted)))
 171                          (out ->  (derivation->output-path grafted)))
 172       (return (and (string=? (readlink (string-append out "/bash"))
 173                              fake)
 174                    (file-is-directory? (string-append out "/a/b/c/d")))))))
 175
 176 (test-assert "graft-derivation, no dependencies on grafted output"
 177   (run-with-store %store
 178     (mlet* %store-monad ((fake    (text-file "bash" "Fake bash."))
 179                          (graft -> (graft
 180                                      (origin %bash)
 181                                      (replacement fake)))
 182                          (drv     (gexp->derivation "foo" #~(mkdir #$output)))
 183                          (grafted ((store-lift graft-derivation) drv
 184                                    (list graft))))
 185       (return (eq? grafted drv)))))
 186
 187 (test-assert "graft-derivation, multiple outputs"
 188   (let* ((build `(begin
 189                    (symlink (assoc-ref %build-inputs "a")
 190                             (assoc-ref %outputs "one"))
 191                    (symlink (assoc-ref %outputs "one")
 192                             (assoc-ref %outputs "two"))))
 193          (orig  (build-expression->derivation %store "grafted" build
 194                                               #:inputs `(("a" ,%bash))
 195                                               #:outputs '("one" "two")))
 196          (repl  (add-text-to-store %store "bash" "fake bash"))
 197          (grafted (graft-derivation %store orig
 198                                     (list (graft
 199                                             (origin %bash)
 200                                             (replacement repl))))))
 201     (and (build-derivations %store (list grafted))
 202          (let ((one (derivation->output-path grafted "one"))
 203                (two (derivation->output-path grafted "two")))
 204            (and (string=? (readlink one) repl)
 205                 (string=? (readlink two) one))))))
 206
 207 (test-assert "graft-derivation, replaced derivation has multiple outputs"
 208   ;; Here we have a replacement just for output "one" of P1 and not for the
 209   ;; other output.  Make sure the graft for P1:one correctly applies to the
 210   ;; dependents of P1.  See <http://bugs.gnu.org/24712>.
 211   (let* ((p1  (build-expression->derivation
 212                %store "p1"
 213                `(let ((one (assoc-ref %outputs "one"))
 214                       (two (assoc-ref %outputs "two")))
 215                   (mkdir one)
 216                   (mkdir two))
 217                #:outputs '("one" "two")))
 218          (p1r (build-expression->derivation
 219                %store "P1"
 220                `(let ((other (assoc-ref %outputs "ONE")))
 221                   (mkdir other)
 222                   (call-with-output-file (string-append other "/replacement")
 223                     (const #t)))
 224                #:outputs '("ONE")))
 225          (p2  (build-expression->derivation
 226                %store "p2"
 227                `(let ((out (assoc-ref %outputs "aaa")))
 228                   (mkdir (assoc-ref %outputs "zzz"))
 229                   (mkdir out) (chdir out)
 230                   (symlink (assoc-ref %build-inputs "p1:one") "one")
 231                   (symlink (assoc-ref %build-inputs "p1:two") "two"))
 232                #:outputs '("aaa" "zzz")
 233                #:inputs `(("p1:one" ,p1 "one")
 234                           ("p1:two" ,p1 "two"))))
 235          (p3  (build-expression->derivation
 236                %store "p3"
 237                `(symlink (assoc-ref %build-inputs "p2:aaa")
 238                          (assoc-ref %outputs "out"))
 239                #:inputs `(("p2:aaa" ,p2 "aaa")
 240                           ("p2:zzz" ,p2 "zzz"))))
 241          (p1g (graft
 242                 (origin p1)
 243                 (origin-output "one")
 244                 (replacement p1r)
 245                 (replacement-output "ONE")))
 246          (p3d (graft-derivation %store p3 (list p1g))))
 247
 248     (and (not (find (lambda (input)
 249                       ;; INPUT should not be P2:zzz since the result of P3
 250                       ;; does not depend on it.  See
 251                       ;; <http://bugs.gnu.org/24886>.
 252                       (and (string=? (derivation-input-path input)
 253                                      (derivation-file-name p2))
 254                            (member "zzz"
 255                                    (derivation-input-sub-derivations input))))
 256                     (derivation-inputs p3d)))
 257
 258          (build-derivations %store (list p3d))
 259          (let ((out (derivation->output-path (pk 'p2d p3d))))
 260            (and (not (string=? (readlink out)
 261                                (derivation->output-path p2 "aaa")))
 262                 (string=? (derivation->output-path p1 "two")
 263                           (readlink (string-append out "/two")))
 264                 (file-exists? (string-append out "/one/replacement")))))))
 265
 266 (test-assert "graft-derivation with #:outputs"
 267   ;; Call 'graft-derivation' with a narrowed set of outputs passed as
 268   ;; #:outputs.
 269   (let* ((p1  (build-expression->derivation
 270                %store "p1"
 271                `(let ((one (assoc-ref %outputs "one"))
 272                       (two (assoc-ref %outputs "two")))
 273                   (mkdir one)
 274                   (mkdir two))
 275                #:outputs '("one" "two")))
 276          (p1r (build-expression->derivation
 277                %store "P1"
 278                `(let ((other (assoc-ref %outputs "ONE")))
 279                   (mkdir other)
 280                   (call-with-output-file (string-append other "/replacement")
 281                     (const #t)))
 282                #:outputs '("ONE")))
 283          (p2  (build-expression->derivation
 284                %store "p2"
 285                `(let ((aaa (assoc-ref %outputs "aaa"))
 286                       (zzz (assoc-ref %outputs "zzz")))
 287                   (mkdir zzz) (chdir zzz)
 288                   (mkdir aaa) (chdir aaa)
 289                   (symlink (assoc-ref %build-inputs "p1:two") "two"))
 290                #:outputs '("aaa" "zzz")
 291                #:inputs `(("p1:one" ,p1 "one")
 292                           ("p1:two" ,p1 "two"))))
 293          (p1g (graft
 294                 (origin p1)
 295                 (origin-output "one")
 296                 (replacement p1r)
 297                 (replacement-output "ONE")))
 298          (p2g (graft-derivation %store p2 (list p1g)
 299                                 #:outputs '("aaa"))))
 300     ;; P2:aaa depends on P1:two, but not on P1:one, so nothing to graft.
 301     (eq? p2g p2)))
 302
 303 (test-equal "graft-derivation, unused outputs not depended on"
 304   '("aaa")
 305
 306   ;; Make sure that the result of 'graft-derivation' does not pull outputs
 307   ;; that are irrelevant to the grafting process.  See
 308   ;; <http://bugs.gnu.org/24886>.
 309   (let* ((p1  (build-expression->derivation
 310                %store "p1"
 311                `(let ((one (assoc-ref %outputs "one"))
 312                       (two (assoc-ref %outputs "two")))
 313                   (mkdir one)
 314                   (mkdir two))
 315                #:outputs '("one" "two")))
 316          (p1r (build-expression->derivation
 317                %store "P1"
 318                `(let ((other (assoc-ref %outputs "ONE")))
 319                   (mkdir other)
 320                   (call-with-output-file (string-append other "/replacement")
 321                     (const #t)))
 322                #:outputs '("ONE")))
 323          (p2  (build-expression->derivation
 324                %store "p2"
 325                `(let ((aaa (assoc-ref %outputs "aaa"))
 326                       (zzz (assoc-ref %outputs "zzz")))
 327                   (mkdir zzz) (chdir zzz)
 328                   (symlink (assoc-ref %build-inputs "p1:two") "two")
 329                   (mkdir aaa) (chdir aaa)
 330                   (symlink (assoc-ref %build-inputs "p1:one") "one"))
 331                #:outputs '("aaa" "zzz")
 332                #:inputs `(("p1:one" ,p1 "one")
 333                           ("p1:two" ,p1 "two"))))
 334          (p1g (graft
 335                 (origin p1)
 336                 (origin-output "one")
 337                 (replacement p1r)
 338                 (replacement-output "ONE")))
 339          (p2g (graft-derivation %store p2 (list p1g)
 340                                 #:outputs '("aaa"))))
 341
 342     ;; Here P2G should only depend on P1:one and P1R:one; it must not depend
 343     ;; on P1:two or P1R:two since these are unused in the grafting process.
 344     (and (not (eq? p2g p2))
 345          (let* ((inputs      (derivation-inputs p2g))
 346                 (match-input (lambda (drv)
 347                                (lambda (input)
 348                                  (string=? (derivation-input-path input)
 349                                            (derivation-file-name drv)))))
 350                 (p1-inputs   (filter (match-input p1) inputs))
 351                 (p1r-inputs  (filter (match-input p1r) inputs))
 352                 (p2-inputs   (filter (match-input p2) inputs)))
 353            (and (equal? p1-inputs
 354                         (list (make-derivation-input (derivation-file-name p1)
 355                                                      '("one"))))
 356                 (equal? p1r-inputs
 357                         (list
 358                          (make-derivation-input (derivation-file-name p1r)
 359                                                 '("ONE"))))
 360                 (equal? p2-inputs
 361                         (list
 362                          (make-derivation-input (derivation-file-name p2)
 363                                                 '("aaa"))))
 364                 (derivation-output-names p2g))))))
 365
 366 (test-assert "graft-derivation, renaming"         ;<http://bugs.gnu.org/23132>
 367   (let* ((build `(begin
 368                    (use-modules (guix build utils))
 369                    (mkdir-p (string-append (assoc-ref %outputs "out") "/"
 370                                            (assoc-ref %build-inputs "in")))))
 371          (orig  (build-expression->derivation %store "thing-to-graft" build
 372                                               #:modules '((guix build utils))
 373                                               #:inputs `(("in" ,%bash))))
 374          (repl  (add-text-to-store %store "bash" "fake bash"))
 375          (grafted (graft-derivation %store orig
 376                                     (list (graft
 377                                             (origin %bash)
 378                                             (replacement repl))))))
 379     (and (build-derivations %store (list grafted))
 380          (let ((out (derivation->output-path grafted)))
 381            (file-is-directory? (string-append out "/" repl))))))
 382
 383 (test-assert "graft-derivation, grafts are not shadowed"
 384   ;; We build a DAG as below, where dotted arrows represent replacements and
 385   ;; solid arrows represent dependencies:
 386   ;;
 387   ;;  P1  ·············>  P1R
 388   ;;  |\__________________.
 389   ;;  v                   v
 390   ;;  P2  ·············>  P2R
 391   ;;  |
 392   ;;  v
 393   ;;  P3
 394   ;;
 395   ;; We want to make sure that the two grafts we want to apply to P3 are
 396   ;; honored and not shadowed by other computed grafts.
 397   (let* ((p1     (build-expression->derivation
 398                   %store "p1"
 399                   '(mkdir (assoc-ref %outputs "out"))))
 400          (p1r    (build-expression->derivation
 401                   %store "P1"
 402                   '(let ((out (assoc-ref %outputs "out")))
 403                      (mkdir out)
 404                      (call-with-output-file (string-append out "/replacement")
 405                        (const #t)))))
 406          (p2     (build-expression->derivation
 407                   %store "p2"
 408                   `(let ((out (assoc-ref %outputs "out")))
 409                      (mkdir out)
 410                      (chdir out)
 411                      (symlink (assoc-ref %build-inputs "p1") "p1"))
 412                   #:inputs `(("p1" ,p1))))
 413          (p2r    (build-expression->derivation
 414                   %store "P2"
 415                   `(let ((out (assoc-ref %outputs "out")))
 416                      (mkdir out)
 417                      (chdir out)
 418                      (symlink (assoc-ref %build-inputs "p1") "p1")
 419                      (call-with-output-file (string-append out "/replacement")
 420                        (const #t)))
 421                   #:inputs `(("p1" ,p1))))
 422          (p3     (build-expression->derivation
 423                   %store "p3"
 424                   `(let ((out (assoc-ref %outputs "out")))
 425                      (mkdir out)
 426                      (chdir out)
 427                      (symlink (assoc-ref %build-inputs "p2") "p2"))
 428                   #:inputs `(("p2" ,p2))))
 429          (p1g    (graft
 430                    (origin p1)
 431                    (replacement p1r)))
 432          (p2g    (graft
 433                    (origin p2)
 434                    (replacement (graft-derivation %store p2r (list p1g)))))
 435          (p3d    (graft-derivation %store p3 (list p1g p2g))))
 436     (and (build-derivations %store (list p3d))
 437          (let ((out (derivation->output-path (pk p3d))))
 438            ;; Make sure OUT refers to the replacement of P2, which in turn
 439            ;; refers to the replacement of P1, as specified by P1G and P2G.
 440            ;; It used to be the case that P2G would be shadowed by a simple
 441            ;; P2->P2R graft, which is not what we want.
 442            (and (file-exists? (string-append out "/p2/replacement"))
 443                 (file-exists? (string-append out "/p2/p1/replacement")))))))
 444
 445 (test-end)