tests/grafts.scm

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