tests/grafts.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014-2019, 2022 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2021 Mark H Weaver <mhw@netris.org>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (test-grafts)
  21   #:use-module (guix gexp)
  22   #:use-module (guix monads)
  23   #:use-module (guix derivations)
  24   #:use-module (guix store)
  25   #:use-module (guix utils)
  26   #:use-module (guix grafts)
  27   #:use-module (guix tests)
  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 ;; When grafting, do not add dependency on 'glibc-utf8-locales'.
  39 (%graft-with-utf8-locale? #f)
  40
  41 (define (bootstrap-binary name)
  42   (let ((bin (search-bootstrap-binary name (%current-system))))
  43     (and %store
  44          (add-to-store %store name #t "sha256" bin))))
  45
  46 (define %bash
  47   (bootstrap-binary "bash"))
  48 (define %mkdir
  49   (bootstrap-binary "mkdir"))
  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 (derivation-input p1 '("one"))))
 360                 (equal? p1r-inputs
 361                         (list (derivation-input p1r '("ONE"))))
 362                 (equal? p2-inputs
 363                         (list (derivation-input p2 '("aaa"))))
 364                 (derivation-output-names p2g))))))
 365
 366 (test-assert "graft-derivation, renaming"         ;<http://bugs.gnu.org/23132>
 367   (let* ((build `(begin
 368                    (use-modules (guix build utils))
 369                    (mkdir-p (string-append (assoc-ref %outputs "out") "/"
 370                                            (assoc-ref %build-inputs "in")))))
 371          (orig  (build-expression->derivation %store "thing-to-graft" build
 372                                               #:modules '((guix build utils))
 373                                               #:inputs `(("in" ,%bash))))
 374          (repl  (add-text-to-store %store "bash" "fake bash"))
 375          (grafted (graft-derivation %store orig
 376                                     (list (graft
 377                                             (origin %bash)
 378                                             (replacement repl))))))
 379     (and (build-derivations %store (list grafted))
 380          (let ((out (derivation->output-path grafted)))
 381            (file-is-directory? (string-append out "/" repl))))))
 382
 383 (test-assert "graft-derivation, grafts are not shadowed"
 384   ;; We build a DAG as below, where dotted arrows represent replacements and
 385   ;; solid arrows represent dependencies:
 386   ;;
 387   ;;  P1  ·············>  P1R
 388   ;;  |\__________________.
 389   ;;  v                   v
 390   ;;  P2  ·············>  P2R
 391   ;;  |
 392   ;;  v
 393   ;;  P3
 394   ;;
 395   ;; We want to make sure that the two grafts we want to apply to P3 are
 396   ;; honored and not shadowed by other computed grafts.
 397   (let* ((p1     (build-expression->derivation
 398                   %store "p1"
 399                   '(mkdir (assoc-ref %outputs "out"))))
 400          (p1r    (build-expression->derivation
 401                   %store "P1"
 402                   '(let ((out (assoc-ref %outputs "out")))
 403                      (mkdir out)
 404                      (call-with-output-file (string-append out "/replacement")
 405                        (const #t)))))
 406          (p2     (build-expression->derivation
 407                   %store "p2"
 408                   `(let ((out (assoc-ref %outputs "out")))
 409                      (mkdir out)
 410                      (chdir out)
 411                      (symlink (assoc-ref %build-inputs "p1") "p1"))
 412                   #:inputs `(("p1" ,p1))))
 413          (p2r    (build-expression->derivation
 414                   %store "P2"
 415                   `(let ((out (assoc-ref %outputs "out")))
 416                      (mkdir out)
 417                      (chdir out)
 418                      (symlink (assoc-ref %build-inputs "p1") "p1")
 419                      (call-with-output-file (string-append out "/replacement")
 420                        (const #t)))
 421                   #:inputs `(("p1" ,p1))))
 422          (p3     (build-expression->derivation
 423                   %store "p3"
 424                   `(let ((out (assoc-ref %outputs "out")))
 425                      (mkdir out)
 426                      (chdir out)
 427                      (symlink (assoc-ref %build-inputs "p2") "p2"))
 428                   #:inputs `(("p2" ,p2))))
 429          (p1g    (graft
 430                    (origin p1)
 431                    (replacement p1r)))
 432          (p2g    (graft
 433                    (origin p2)
 434                    (replacement (graft-derivation %store p2r (list p1g)))))
 435          (p3d    (graft-derivation %store p3 (list p1g p2g))))
 436     (and (build-derivations %store (list p3d))
 437          (let ((out (derivation->output-path (pk p3d))))
 438            ;; Make sure OUT refers to the replacement of P2, which in turn
 439            ;; refers to the replacement of P1, as specified by P1G and P2G.
 440            ;; It used to be the case that P2G would be shadowed by a simple
 441            ;; P2->P2R graft, which is not what we want.
 442            (and (file-exists? (string-append out "/p2/replacement"))
 443                 (file-exists? (string-append out "/p2/p1/replacement")))))))
 444
 445 (define buffer-size
 446   ;; Must be equal to REQUEST-SIZE in 'replace-store-references'.
 447   (expt 2 20))
 448
 449 (test-equal "replace-store-references, <http://bugs.gnu.org/28212>"
 450   (string-append (make-string (- buffer-size 47) #\a)
 451                  "/gnu/store/" (make-string 32 #\8)
 452                  "-SoMeTHiNG"
 453                  (list->string (map integer->char (iota 77 33))))
 454
 455   ;; Create input data where the right-hand-size of the dash ("-something"
 456   ;; here) goes beyond the end of the internal buffer of
 457   ;; 'replace-store-references'.
 458   (let* ((content     (string-append (make-string (- buffer-size 47) #\a)
 459                                      "/gnu/store/" (make-string 32 #\7)
 460                                      "-something"
 461                                      (list->string
 462                                       (map integer->char (iota 77 33)))))
 463          (replacement (alist->vhash
 464                        `((,(make-string 32 #\7)
 465                           . ,(string->utf8 (string-append
 466                                             (make-string 32 #\8)
 467                                             "-SoMeTHiNG")))))))
 468     (call-with-output-string
 469       (lambda (output)
 470         ((@@ (guix build graft) replace-store-references)
 471          (open-input-string content) output
 472          replacement
 473          "/gnu/store")))))
 474
 475 (define (insert-nuls char-size str)
 476   (string-join (map string (string->list str))
 477                (make-string (- char-size 1) #\nul)))
 478
 479 (define (nuls-to-underscores s)
 480   (string-replace-substring s "\0" "_"))
 481
 482 (define (annotate-buffer-boundary s)
 483   (string-append (string-take s buffer-size)
 484                  "|"
 485                  (string-drop s buffer-size)))
 486
 487 (define (abbreviate-leading-fill s)
 488   (let ((s* (string-trim s #\=)))
 489     (format #f "[~a =s]~a"
 490             (- (string-length s)
 491                (string-length s*))
 492             s*)))
 493
 494 (define (prettify-for-display s)
 495   (abbreviate-leading-fill
 496    (annotate-buffer-boundary
 497     (nuls-to-underscores s))))
 498
 499 (define (two-sample-refs-with-gap char-size1 char-size2 gap offset
 500                                   char1 name1 char2 name2)
 501   (string-append
 502    (make-string (- buffer-size offset) #\=)
 503    (insert-nuls char-size1
 504                 (string-append "/gnu/store/" (make-string 32 char1) name1))
 505    gap
 506    (insert-nuls char-size2
 507                 (string-append "/gnu/store/" (make-string 32 char2) name2))
 508    (list->string (map integer->char (iota 77 33)))))
 509
 510 (define (sample-map-entry old-char new-char new-name)
 511   (cons (make-string 32 old-char)
 512         (string->utf8 (string-append (make-string 32 new-char)
 513                                      new-name))))
 514
 515 (define (test-two-refs-with-gap char-size1 char-size2 gap offset)
 516   (test-equal
 517       (format #f "test-two-refs-with-gap, char-sizes ~a ~a, gap ~s, offset ~a"
 518               char-size1 char-size2 gap offset)
 519     (prettify-for-display
 520      (two-sample-refs-with-gap char-size1 char-size2 gap offset
 521                                #\6 "-BlahBlaH"
 522                                #\8"-SoMeTHiNG"))
 523     (prettify-for-display
 524      (let* ((content (two-sample-refs-with-gap char-size1 char-size2 gap offset
 525                                                #\5 "-blahblah"
 526                                                #\7 "-something"))
 527             (replacement (alist->vhash
 528                           (list (sample-map-entry #\5 #\6 "-BlahBlaH")
 529                                 (sample-map-entry #\7 #\8 "-SoMeTHiNG")))))
 530        (call-with-output-string
 531          (lambda (output)
 532            ((@@ (guix build graft) replace-store-references)
 533             (open-input-string content) output
 534             replacement
 535             "/gnu/store")))))))
 536
 537 (for-each (lambda (char-size1)
 538             (for-each (lambda (char-size2)
 539                         (for-each (lambda (gap)
 540                                     (for-each (lambda (offset)
 541                                                 (test-two-refs-with-gap char-size1
 542                                                                         char-size2
 543                                                                         gap
 544                                                                         offset))
 545                                               ;; offsets to test
 546                                               (map (lambda (i)
 547                                                      (+ i (* 40 char-size1)))
 548                                                    (iota 30))))
 549                                   ;; gaps
 550                                   '("" "-" " " "a")))
 551                       ;; char-size2 values to test
 552                       '(1 2)))
 553           ;; char-size1 values to test
 554           '(1 2 4))
 555
 556
 557 (test-end)