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