tests/grafts.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2015, 2016 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 io ports))
  32
  33 (define %store
  34   (open-connection-for-tests))
  35
  36 (define (bootstrap-binary name)
  37   (let ((bin (search-bootstrap-binary name (%current-system))))
  38     (and %store
  39          (add-to-store %store name #t "sha256" bin))))
  40
  41 (define %bash
  42   (bootstrap-binary "bash"))
  43 (define %mkdir
  44   (bootstrap-binary "mkdir"))
  45
  46 \f
  47 (test-begin "grafts")
  48
  49 (test-assert "graft-derivation, grafted item is a direct dependency"
  50   (let* ((build `(begin
  51                    (mkdir %output)
  52                    (chdir %output)
  53                    (symlink %output "self")
  54                    (call-with-output-file "text"
  55                      (lambda (output)
  56                        (format output "foo/~a/bar" ,%mkdir)))
  57                    (symlink ,%bash "sh")))
  58          (orig  (build-expression->derivation %store "grafted" build
  59                                               #:inputs `(("a" ,%bash)
  60                                                          ("b" ,%mkdir))))
  61          (one   (add-text-to-store %store "bash" "fake bash"))
  62          (two   (build-expression->derivation %store "mkdir"
  63                                               '(call-with-output-file %output
  64                                                  (lambda (port)
  65                                                    (display "fake mkdir" port)))))
  66          (grafted (graft-derivation %store orig
  67                                     (list (graft
  68                                             (origin %bash)
  69                                             (replacement one))
  70                                           (graft
  71                                             (origin %mkdir)
  72                                             (replacement two))))))
  73     (and (build-derivations %store (list grafted))
  74          (let ((two     (derivation->output-path two))
  75                (grafted (derivation->output-path grafted)))
  76            (and (string=? (format #f "foo/~a/bar" two)
  77                           (call-with-input-file (string-append grafted "/text")
  78                             get-string-all))
  79                 (string=? (readlink (string-append grafted "/sh")) one)
  80                 (string=? (readlink (string-append grafted "/self"))
  81                           grafted))))))
  82
  83 (test-assert "graft-derivation, grafted item uses a different name"
  84   (let* ((build   `(begin
  85                      (mkdir %output)
  86                      (chdir %output)
  87                      (symlink %output "self")
  88                      (symlink ,%bash "sh")))
  89          (orig    (build-expression->derivation %store "grafted" build
  90                                                 #:inputs `(("a" ,%bash))))
  91          (repl    (add-text-to-store %store "BaSH" "fake bash"))
  92          (grafted (graft-derivation %store orig
  93                                     (list (graft
  94                                             (origin %bash)
  95                                             (replacement repl))))))
  96     (and (build-derivations %store (list grafted))
  97          (let ((grafted (derivation->output-path grafted)))
  98            (and (string=? (readlink (string-append grafted "/sh")) repl)
  99                 (string=? (readlink (string-append grafted "/self"))
 100                           grafted))))))
 101
 102 ;; Make sure 'derivation-file-name' always gets to see an absolute file name.
 103 (fluid-set! %file-port-name-canonicalization 'absolute)
 104
 105 (test-assert "graft-derivation, grafted item is an indirect dependency"
 106   (let* ((build `(begin
 107                    (mkdir %output)
 108                    (chdir %output)
 109                    (symlink %output "self")
 110                    (call-with-output-file "text"
 111                      (lambda (output)
 112                        (format output "foo/~a/bar" ,%mkdir)))
 113                    (symlink ,%bash "sh")))
 114          (dep   (build-expression->derivation %store "dep" build
 115                                               #:inputs `(("a" ,%bash)
 116                                                          ("b" ,%mkdir))))
 117          (orig  (build-expression->derivation %store "thing"
 118                                               '(symlink
 119                                                 (assoc-ref %build-inputs
 120                                                            "dep")
 121                                                 %output)
 122                                               #:inputs `(("dep" ,dep))))
 123          (one   (add-text-to-store %store "bash" "fake bash"))
 124          (two   (build-expression->derivation %store "mkdir"
 125                                               '(call-with-output-file %output
 126                                                  (lambda (port)
 127                                                    (display "fake mkdir" port)))))
 128          (grafted (graft-derivation %store orig
 129                                     (list (graft
 130                                             (origin %bash)
 131                                             (replacement one))
 132                                           (graft
 133                                             (origin %mkdir)
 134                                             (replacement two))))))
 135     (and (build-derivations %store (list grafted))
 136          (let* ((two     (derivation->output-path two))
 137                 (grafted (derivation->output-path grafted))
 138                 (dep     (readlink grafted)))
 139            (and (string=? (format #f "foo/~a/bar" two)
 140                           (call-with-input-file (string-append dep "/text")
 141                             get-string-all))
 142                 (string=? (readlink (string-append dep "/sh")) one)
 143                 (string=? (readlink (string-append dep "/self")) dep)
 144                 (equal? (references %store grafted) (list dep))
 145                 (lset= string=?
 146                        (list one two dep)
 147                        (references %store dep)))))))
 148
 149 (test-assert "graft-derivation, preserve empty directories"
 150   (run-with-store %store
 151     (mlet* %store-monad ((fake    (text-file "bash" "Fake bash."))
 152                          (graft -> (graft
 153                                      (origin %bash)
 154                                      (replacement fake)))
 155                          (drv     (gexp->derivation
 156                                    "to-graft"
 157                                    (with-imported-modules '((guix build utils))
 158                                      #~(begin
 159                                          (use-modules (guix build utils))
 160                                          (mkdir-p (string-append #$output
 161                                                                  "/a/b/c/d"))
 162                                          (symlink #$%bash
 163                                                   (string-append #$output
 164                                                                  "/bash"))))))
 165                          (grafted ((store-lift graft-derivation) drv
 166                                    (list graft)))
 167                          (_       (built-derivations (list grafted)))
 168                          (out ->  (derivation->output-path grafted)))
 169       (return (and (string=? (readlink (string-append out "/bash"))
 170                              fake)
 171                    (file-is-directory? (string-append out "/a/b/c/d")))))))
 172
 173 (test-assert "graft-derivation, no dependencies on grafted output"
 174   (run-with-store %store
 175     (mlet* %store-monad ((fake    (text-file "bash" "Fake bash."))
 176                          (graft -> (graft
 177                                      (origin %bash)
 178                                      (replacement fake)))
 179                          (drv     (gexp->derivation "foo" #~(mkdir #$output)))
 180                          (grafted ((store-lift graft-derivation) drv
 181                                    (list graft))))
 182       (return (eq? grafted drv)))))
 183
 184 (test-assert "graft-derivation, multiple outputs"
 185   (let* ((build `(begin
 186                    (symlink (assoc-ref %build-inputs "a")
 187                             (assoc-ref %outputs "one"))
 188                    (symlink (assoc-ref %outputs "one")
 189                             (assoc-ref %outputs "two"))))
 190          (orig  (build-expression->derivation %store "grafted" build
 191                                               #:inputs `(("a" ,%bash))
 192                                               #:outputs '("one" "two")))
 193          (repl  (add-text-to-store %store "bash" "fake bash"))
 194          (grafted (graft-derivation %store orig
 195                                     (list (graft
 196                                             (origin %bash)
 197                                             (replacement repl))))))
 198     (and (build-derivations %store (list grafted))
 199          (let ((one (derivation->output-path grafted "one"))
 200                (two (derivation->output-path grafted "two")))
 201            (and (string=? (readlink one) repl)
 202                 (string=? (readlink two) one))))))
 203
 204 (test-assert "graft-derivation, replaced derivation has multiple outputs"
 205   ;; Here we have a replacement just for output "one" of P1 and not for the
 206   ;; other output.  Make sure the graft for P1:one correctly applies to the
 207   ;; dependents of P1.  See <http://bugs.gnu.org/24712>.
 208   (let* ((p1  (build-expression->derivation
 209                %store "p1"
 210                `(let ((one (assoc-ref %outputs "one"))
 211                       (two (assoc-ref %outputs "two")))
 212                   (mkdir one)
 213                   (mkdir two))
 214                #:outputs '("one" "two")))
 215          (p1r (build-expression->derivation
 216                %store "P1"
 217                `(let ((other (assoc-ref %outputs "ONE")))
 218                   (mkdir other)
 219                   (call-with-output-file (string-append other "/replacement")
 220                     (const #t)))
 221                #:outputs '("ONE")))
 222          (p2  (build-expression->derivation
 223                %store "p2"
 224                `(let ((out (assoc-ref %outputs "aaa")))
 225                   (mkdir (assoc-ref %outputs "zzz"))
 226                   (mkdir out) (chdir out)
 227                   (symlink (assoc-ref %build-inputs "p1:one") "one")
 228                   (symlink (assoc-ref %build-inputs "p1:two") "two"))
 229                #:outputs '("aaa" "zzz")
 230                #:inputs `(("p1:one" ,p1 "one")
 231                           ("p1:two" ,p1 "two"))))
 232          (p3  (build-expression->derivation
 233                %store "p3"
 234                `(symlink (assoc-ref %build-inputs "p2:aaa")
 235                          (assoc-ref %outputs "out"))
 236                #:inputs `(("p2:aaa" ,p2 "aaa")
 237                           ("p2:zzz" ,p2 "zzz"))))
 238          (p1g (graft
 239                 (origin p1)
 240                 (origin-output "one")
 241                 (replacement p1r)
 242                 (replacement-output "ONE")))
 243          (p3d (graft-derivation %store p3 (list p1g))))
 244     (and (build-derivations %store (list p3d))
 245          (let ((out (derivation->output-path (pk 'p2d p3d))))
 246            (and (not (string=? (readlink out)
 247                                (derivation->output-path p2 "aaa")))
 248                 (string=? (derivation->output-path p1 "two")
 249                           (readlink (string-append out "/two")))
 250                 (file-exists? (string-append out "/one/replacement")))))))
 251
 252 (test-assert "graft-derivation, renaming"         ;<http://bugs.gnu.org/23132>
 253   (let* ((build `(begin
 254                    (use-modules (guix build utils))
 255                    (mkdir-p (string-append (assoc-ref %outputs "out") "/"
 256                                            (assoc-ref %build-inputs "in")))))
 257          (orig  (build-expression->derivation %store "thing-to-graft" build
 258                                               #:modules '((guix build utils))
 259                                               #:inputs `(("in" ,%bash))))
 260          (repl  (add-text-to-store %store "bash" "fake bash"))
 261          (grafted (graft-derivation %store orig
 262                                     (list (graft
 263                                             (origin %bash)
 264                                             (replacement repl))))))
 265     (and (build-derivations %store (list grafted))
 266          (let ((out (derivation->output-path grafted)))
 267            (file-is-directory? (string-append out "/" repl))))))
 268
 269 (test-assert "graft-derivation, grafts are not shadowed"
 270   ;; We build a DAG as below, where dotted arrows represent replacements and
 271   ;; solid arrows represent dependencies:
 272   ;;
 273   ;;  P1  ·············>  P1R
 274   ;;  |\__________________.
 275   ;;  v                   v
 276   ;;  P2  ·············>  P2R
 277   ;;  |
 278   ;;  v
 279   ;;  P3
 280   ;;
 281   ;; We want to make sure that the two grafts we want to apply to P3 are
 282   ;; honored and not shadowed by other computed grafts.
 283   (let* ((p1     (build-expression->derivation
 284                   %store "p1"
 285                   '(mkdir (assoc-ref %outputs "out"))))
 286          (p1r    (build-expression->derivation
 287                   %store "P1"
 288                   '(let ((out (assoc-ref %outputs "out")))
 289                      (mkdir out)
 290                      (call-with-output-file (string-append out "/replacement")
 291                        (const #t)))))
 292          (p2     (build-expression->derivation
 293                   %store "p2"
 294                   `(let ((out (assoc-ref %outputs "out")))
 295                      (mkdir out)
 296                      (chdir out)
 297                      (symlink (assoc-ref %build-inputs "p1") "p1"))
 298                   #:inputs `(("p1" ,p1))))
 299          (p2r    (build-expression->derivation
 300                   %store "P2"
 301                   `(let ((out (assoc-ref %outputs "out")))
 302                      (mkdir out)
 303                      (chdir out)
 304                      (symlink (assoc-ref %build-inputs "p1") "p1")
 305                      (call-with-output-file (string-append out "/replacement")
 306                        (const #t)))
 307                   #:inputs `(("p1" ,p1))))
 308          (p3     (build-expression->derivation
 309                   %store "p3"
 310                   `(let ((out (assoc-ref %outputs "out")))
 311                      (mkdir out)
 312                      (chdir out)
 313                      (symlink (assoc-ref %build-inputs "p2") "p2"))
 314                   #:inputs `(("p2" ,p2))))
 315          (p1g    (graft
 316                    (origin p1)
 317                    (replacement p1r)))
 318          (p2g    (graft
 319                    (origin p2)
 320                    (replacement (graft-derivation %store p2r (list p1g)))))
 321          (p3d    (graft-derivation %store p3 (list p1g p2g))))
 322     (and (build-derivations %store (list p3d))
 323          (let ((out (derivation->output-path (pk p3d))))
 324            ;; Make sure OUT refers to the replacement of P2, which in turn
 325            ;; refers to the replacement of P1, as specified by P1G and P2G.
 326            ;; It used to be the case that P2G would be shadowed by a simple
 327            ;; P2->P2R graft, which is not what we want.
 328            (and (file-exists? (string-append out "/p2/replacement"))
 329                 (file-exists? (string-append out "/p2/p1/replacement")))))))
 330
 331 (test-end)