tests/grafts.scm

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