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, renaming"         ;<http://bugs.gnu.org/23132>
 205   (let* ((build `(begin
 206                    (use-modules (guix build utils))
 207                    (mkdir-p (string-append (assoc-ref %outputs "out") "/"
 208                                            (assoc-ref %build-inputs "in")))))
 209          (orig  (build-expression->derivation %store "thing-to-graft" build
 210                                               #:modules '((guix build utils))
 211                                               #:inputs `(("in" ,%bash))))
 212          (repl  (add-text-to-store %store "bash" "fake bash"))
 213          (grafted (graft-derivation %store orig
 214                                     (list (graft
 215                                             (origin %bash)
 216                                             (replacement repl))))))
 217     (and (build-derivations %store (list grafted))
 218          (let ((out (derivation->output-path grafted)))
 219            (file-is-directory? (string-append out "/" repl))))))
 220
 221 (test-assert "graft-derivation, grafts are not shadowed"
 222   ;; We build a DAG as below, where dotted arrows represent replacements and
 223   ;; solid arrows represent dependencies:
 224   ;;
 225   ;;  P1  ·············>  P1R
 226   ;;  |\__________________.
 227   ;;  v                   v
 228   ;;  P2  ·············>  P2R
 229   ;;  |
 230   ;;  v
 231   ;;  P3
 232   ;;
 233   ;; We want to make sure that the two grafts we want to apply to P3 are
 234   ;; honored and not shadowed by other computed grafts.
 235   (let* ((p1     (build-expression->derivation
 236                   %store "p1"
 237                   '(mkdir (assoc-ref %outputs "out"))))
 238          (p1r    (build-expression->derivation
 239                   %store "P1"
 240                   '(let ((out (assoc-ref %outputs "out")))
 241                      (mkdir out)
 242                      (call-with-output-file (string-append out "/replacement")
 243                        (const #t)))))
 244          (p2     (build-expression->derivation
 245                   %store "p2"
 246                   `(let ((out (assoc-ref %outputs "out")))
 247                      (mkdir out)
 248                      (chdir out)
 249                      (symlink (assoc-ref %build-inputs "p1") "p1"))
 250                   #:inputs `(("p1" ,p1))))
 251          (p2r    (build-expression->derivation
 252                   %store "P2"
 253                   `(let ((out (assoc-ref %outputs "out")))
 254                      (mkdir out)
 255                      (chdir out)
 256                      (symlink (assoc-ref %build-inputs "p1") "p1")
 257                      (call-with-output-file (string-append out "/replacement")
 258                        (const #t)))
 259                   #:inputs `(("p1" ,p1))))
 260          (p3     (build-expression->derivation
 261                   %store "p3"
 262                   `(let ((out (assoc-ref %outputs "out")))
 263                      (mkdir out)
 264                      (chdir out)
 265                      (symlink (assoc-ref %build-inputs "p2") "p2"))
 266                   #:inputs `(("p2" ,p2))))
 267          (p1g    (graft
 268                    (origin p1)
 269                    (replacement p1r)))
 270          (p2g    (graft
 271                    (origin p2)
 272                    (replacement (graft-derivation %store p2r (list p1g)))))
 273          (p3d    (graft-derivation %store p3 (list p1g p2g))))
 274     (and (build-derivations %store (list p3d))
 275          (let ((out (derivation->output-path (pk p3d))))
 276            ;; Make sure OUT refers to the replacement of P2, which in turn
 277            ;; refers to the replacement of P1, as specified by P1G and P2G.
 278            ;; It used to be the case that P2G would be shadowed by a simple
 279            ;; P2->P2R graft, which is not what we want.
 280            (and (file-exists? (string-append out "/p2/replacement"))
 281                 (file-exists? (string-append out "/p2/p1/replacement")))))))
 282
 283 (test-end)