tests/union.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.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-union)
  21   #:use-module (guix tests)
  22   #:use-module (guix store)
  23   #:use-module (guix utils)
  24   #:use-module (guix derivations)
  25   #:use-module (guix packages)
  26   #:use-module (guix build union)
  27   #:use-module ((guix build utils)
  28                 #:select (with-directory-excursion directory-exists?))
  29   #:use-module (gnu packages bootstrap)
  30   #:use-module (srfi srfi-1)
  31   #:use-module (srfi srfi-64)
  32   #:use-module (rnrs io ports)
  33   #:use-module (ice-9 match))
  34
  35 (define %bootstrap-inputs
  36   (@@ (gnu packages commencement) %bootstrap-inputs+toolchain))
  37
  38 ;; Exercise the (guix build union) module.
  39
  40 (define %store
  41   (open-connection-for-tests))
  42
  43 \f
  44 (test-begin "union")
  45
  46 (test-assert "union-build with symlink to directory"
  47   ;; http://bugs.gnu.org/17083
  48   ;; Here both ONE and TWO provide an element called 'foo', but in ONE it's a
  49   ;; directory whereas in TWO it's a symlink to a directory.
  50   (let* ((one     (build-expression->derivation
  51                    %store "one"
  52                    '(begin
  53                       (use-modules (guix build utils) (srfi srfi-26))
  54                       (let ((foo (string-append %output "/foo")))
  55                         (mkdir-p foo)
  56                         (call-with-output-file (string-append foo "/one")
  57                           (cut display "one" <>))))
  58                    #:modules '((guix build utils))))
  59          (two     (build-expression->derivation
  60                    %store "two"
  61                    '(begin
  62                       (use-modules (guix build utils) (srfi srfi-26))
  63                       (let ((foo (string-append %output "/foo"))
  64                             (bar (string-append %output "/bar")))
  65                         (mkdir-p bar)
  66                         (call-with-output-file (string-append bar "/two")
  67                           (cut display "two" <>))
  68                         (symlink "bar" foo)))
  69                    #:modules '((guix build utils))))
  70          (builder '(begin
  71                      (use-modules (guix build union))
  72
  73                      (union-build (assoc-ref %outputs "out")
  74                                   (list (assoc-ref %build-inputs "one")
  75                                         (assoc-ref %build-inputs "two")))))
  76          (drv
  77           (build-expression->derivation %store "union-collision-symlink"
  78                                         builder
  79                                         #:inputs `(("one" ,one) ("two" ,two))
  80                                         #:modules '((guix build union)))))
  81     (and (build-derivations %store (list drv))
  82          (with-directory-excursion (pk (derivation->output-path drv))
  83            (and (string=? "one"
  84                           (call-with-input-file "foo/one" get-string-all))
  85                 (string=? "two"
  86                           (call-with-input-file "foo/two" get-string-all))
  87                 (string=? "two"
  88                           (call-with-input-file "bar/two" get-string-all))
  89                 (not (file-exists? "bar/one")))))))
  90
  91 (test-skip (if (and %store (network-reachable?))
  92                0
  93                1))
  94
  95 (test-assert "union-build"
  96   (let* ((inputs  (map (match-lambda
  97                         ((name package)
  98                          `(,name ,(package-derivation %store package))))
  99
 100                        ;; Purposefully leave duplicate entries.
 101                        (filter (compose package? cadr)
 102                                (append (%bootstrap-inputs)
 103                                 (take (%bootstrap-inputs) 3)))))
 104          (builder `(begin
 105                      (use-modules (guix build union))
 106                      (union-build (assoc-ref %outputs "out")
 107                                   (map cdr %build-inputs))))
 108          (drv
 109           (build-expression->derivation %store "union-test"
 110                                         builder
 111                                         #:inputs inputs
 112                                         #:modules '((guix build union)))))
 113     (and (build-derivations %store (list (pk 'drv drv)))
 114          (with-directory-excursion (derivation->output-path drv)
 115            (and (file-exists? "bin/touch")
 116                 (file-exists? "bin/gcc")
 117                 (file-exists? "bin/ld")
 118                 (file-exists? "lib/libc.so")
 119                 (directory-exists? "lib/gcc")
 120                 (file-exists? "include/unistd.h")
 121
 122                 ;; The 'include/c++' sub-directory is only found in
 123                 ;; gcc-bootstrap, so it should be unified in a
 124                 ;; straightforward way, without traversing it.
 125                 (eq? 'symlink (stat:type (lstat "include/c++")))
 126
 127                 ;; Conversely, several inputs have a 'bin' sub-directory, so
 128                 ;; unifying it requires traversing them all, and creating a
 129                 ;; new 'bin' sub-directory in the profile.
 130                 (eq? 'directory (stat:type (lstat "bin"))))))))
 131
 132 (test-assert "union-build collision first & last"
 133   (let* ((guile   (package-derivation %store %bootstrap-guile))
 134          (fake    (build-expression->derivation
 135                    %store "fake-guile"
 136                    '(begin
 137                       (use-modules (guix build utils))
 138                       (let ((out (assoc-ref %outputs "out")))
 139                         (mkdir-p (string-append out "/bin"))
 140                         (call-with-output-file (string-append out "/bin/guile")
 141                           (const #t))))
 142                    #:modules '((guix build utils))))
 143          (builder (lambda (policy)
 144                     `(begin
 145                        (use-modules (guix build union)
 146                                     (srfi srfi-1))
 147                        (union-build (assoc-ref %outputs "out")
 148                                     (map cdr %build-inputs)
 149                                     #:resolve-collision ,policy))))
 150          (drv1
 151           (build-expression->derivation %store "union-first"
 152                                         (builder 'first)
 153                                         #:inputs `(("guile" ,guile)
 154                                                    ("fake" ,fake))
 155                                         #:modules '((guix build union))))
 156          (drv2
 157           (build-expression->derivation %store "union-last"
 158                                         (builder 'last)
 159                                         #:inputs `(("guile" ,guile)
 160                                                    ("fake" ,fake))
 161                                         #:modules '((guix build union)))))
 162     (and (build-derivations %store (list drv1 drv2))
 163          (with-directory-excursion (derivation->output-path drv1)
 164            (string=? (readlink "bin/guile")
 165                      (string-append (derivation->output-path guile)
 166                                     "/bin/guile")))
 167          (with-directory-excursion (derivation->output-path drv2)
 168            (string=? (readlink "bin/guile")
 169                      (string-append (derivation->output-path fake)
 170                                     "/bin/guile"))))))
 171
 172 (test-assert "union-build #:create-all-directories? #t"
 173   (let* ((build  `(begin
 174                     (use-modules (guix build union))
 175                     (union-build (assoc-ref %outputs "out")
 176                                  (map cdr %build-inputs)
 177                                  #:create-all-directories? #t)))
 178          (input  (package-derivation %store %bootstrap-guile))
 179          (drv    (build-expression->derivation %store "union-test-all-dirs"
 180                                                build
 181                                                #:modules '((guix build union))
 182                                                #:inputs `(("g" ,input)))))
 183     (and (build-derivations %store (list drv))
 184          (with-directory-excursion (derivation->output-path drv)
 185            ;; Even though there's only one input to the union,
 186            ;; #:create-all-directories? #t must have created bin/ rather than
 187            ;; making it a symlink to Guile's bin/.
 188            (and (file-exists? "bin/guile")
 189                 (file-is-directory? "bin")
 190                 (eq? 'symlink (stat:type (lstat "bin/guile"))))))))
 191
 192 (letrec-syntax ((test-relative-file-name
 193                  (syntax-rules (=>)
 194                    ((_ (reference file => expected) rest ...)
 195                     (begin
 196                       (test-equal (string-append "relative-file-name "
 197                                                  reference " " file)
 198                         expected
 199                         (relative-file-name reference file))
 200                       (test-relative-file-name rest ...)))
 201                    ((_)
 202                     #t))))
 203   (test-relative-file-name
 204    ("/a/b" "/a/c/d"     => "../c/d")
 205    ("/a/b" "/a/b"       => "")
 206    ("/a/b" "/a"         => "..")
 207    ("/a/b" "/a/b/c/d"   => "c/d")
 208    ("/a/b/c" "/a/d/e/f" => "../../d/e/f")))
 209
 210 (test-end)