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