tests/gexp.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2015, 2016, 2017 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-gexp)
  20   #:use-module (guix store)
  21   #:use-module (guix monads)
  22   #:use-module (guix gexp)
  23   #:use-module (guix grafts)
  24   #:use-module (guix derivations)
  25   #:use-module (guix packages)
  26   #:use-module (guix tests)
  27   #:use-module ((guix build utils) #:select (with-directory-excursion))
  28   #:use-module (gnu packages)
  29   #:use-module (gnu packages base)
  30   #:use-module (gnu packages bootstrap)
  31   #:use-module (srfi srfi-1)
  32   #:use-module (srfi srfi-34)
  33   #:use-module (srfi srfi-64)
  34   #:use-module (rnrs io ports)
  35   #:use-module (ice-9 match)
  36   #:use-module (ice-9 regex)
  37   #:use-module (ice-9 popen)
  38   #:use-module (ice-9 ftw))
  39
  40 ;; Test the (guix gexp) module.
  41
  42 (define %store
  43   (open-connection-for-tests))
  44
  45 ;; Globally disable grafts because they can trigger early builds.
  46 (%graft? #f)
  47
  48 ;; For white-box testing.
  49 (define (gexp-inputs x)
  50   ((@@ (guix gexp) gexp-inputs) x))
  51 (define (gexp-native-inputs x)
  52   ((@@ (guix gexp) gexp-native-inputs) x))
  53 (define (gexp-outputs x)
  54   ((@@ (guix gexp) gexp-outputs) x))
  55 (define (gexp->sexp . x)
  56   (apply (@@ (guix gexp) gexp->sexp) x))
  57
  58 (define* (gexp->sexp* exp #:optional target)
  59   (run-with-store %store (gexp->sexp exp
  60                                      #:target target)
  61                   #:guile-for-build (%guile-for-build)))
  62
  63 (define-syntax-rule (test-assertm name exp)
  64   (test-assert name
  65     (run-with-store %store exp
  66                     #:guile-for-build (%guile-for-build))))
  67
  68 \f
  69 (test-begin "gexp")
  70
  71 (test-equal "no refs"
  72   '(display "hello!")
  73   (let ((exp (gexp (display "hello!"))))
  74     (and (gexp? exp)
  75          (null? (gexp-inputs exp))
  76          (gexp->sexp* exp))))
  77
  78 (test-equal "unquote"
  79   '(display `(foo ,(+ 2 3)))
  80   (let ((exp (gexp (display `(foo ,(+ 2 3))))))
  81     (and (gexp? exp)
  82          (null? (gexp-inputs exp))
  83          (gexp->sexp* exp))))
  84
  85 (test-assert "one input package"
  86   (let ((exp (gexp (display (ungexp coreutils)))))
  87     (and (gexp? exp)
  88          (match (gexp-inputs exp)
  89            (((p "out"))
  90             (eq? p coreutils)))
  91          (equal? `(display ,(derivation->output-path
  92                              (package-derivation %store coreutils)))
  93                  (gexp->sexp* exp)))))
  94
  95 (test-assert "one input package, dotted list"
  96   (let ((exp (gexp (coreutils . (ungexp coreutils)))))
  97     (and (gexp? exp)
  98          (match (gexp-inputs exp)
  99            (((p "out"))
 100             (eq? p coreutils)))
 101          (equal? `(coreutils . ,(derivation->output-path
 102                                  (package-derivation %store coreutils)))
 103                  (gexp->sexp* exp)))))
 104
 105 (test-assert "one input origin"
 106   (let ((exp (gexp (display (ungexp (package-source coreutils))))))
 107     (and (gexp? exp)
 108          (match (gexp-inputs exp)
 109            (((o "out"))
 110             (eq? o (package-source coreutils))))
 111          (equal? `(display ,(derivation->output-path
 112                              (package-source-derivation
 113                               %store (package-source coreutils))))
 114                  (gexp->sexp* exp)))))
 115
 116 (test-assert "one local file"
 117   (let* ((file  (search-path %load-path "guix.scm"))
 118          (local (local-file file))
 119          (exp   (gexp (display (ungexp local))))
 120          (intd  (add-to-store %store (basename file) #f
 121                               "sha256" file)))
 122     (and (gexp? exp)
 123          (match (gexp-inputs exp)
 124            (((x "out"))
 125             (eq? x local)))
 126          (equal? `(display ,intd) (gexp->sexp* exp)))))
 127
 128 (test-assert "one local file, symlink"
 129   (let ((file (search-path %load-path "guix.scm"))
 130         (link (tmpnam)))
 131     (dynamic-wind
 132       (const #t)
 133       (lambda ()
 134         (symlink (canonicalize-path file) link)
 135         (let* ((local (local-file link "my-file" #:recursive? #f))
 136                (exp   (gexp (display (ungexp local))))
 137                (intd  (add-to-store %store "my-file" #f
 138                                     "sha256" file)))
 139           (and (gexp? exp)
 140                (match (gexp-inputs exp)
 141                  (((x "out"))
 142                   (eq? x local)))
 143                (equal? `(display ,intd) (gexp->sexp* exp)))))
 144       (lambda ()
 145         (false-if-exception (delete-file link))))))
 146
 147 (test-equal "local-file, relative file name"
 148   (canonicalize-path (search-path %load-path "guix/base32.scm"))
 149   (let ((directory (dirname (search-path %load-path
 150                                          "guix/build-system/gnu.scm"))))
 151     (with-directory-excursion directory
 152         (let ((file (local-file "../guix/base32.scm")))
 153           (local-file-absolute-file-name file)))))
 154
 155 (test-assertm "local-file, #:select?"
 156   (mlet* %store-monad ((select? -> (lambda (file stat)
 157                                      (member (basename file)
 158                                              '("guix.scm" "tests"
 159                                                "gexp.scm"))))
 160                        (file -> (local-file ".." "directory"
 161                                             #:recursive? #t
 162                                             #:select? select?))
 163                        (dir (lower-object file)))
 164     (return (and (store-path? dir)
 165                  (equal? (scandir dir)
 166                          '("." ".." "guix.scm" "tests"))
 167                  (equal? (scandir (string-append dir "/tests"))
 168                          '("." ".." "gexp.scm"))))))
 169
 170 (test-assert "one plain file"
 171   (let* ((file     (plain-file "hi" "Hello, world!"))
 172          (exp      (gexp (display (ungexp file))))
 173          (expected (add-text-to-store %store "hi" "Hello, world!")))
 174     (and (gexp? exp)
 175          (match (gexp-inputs exp)
 176            (((x "out"))
 177             (eq? x file)))
 178          (equal? `(display ,expected) (gexp->sexp* exp)))))
 179
 180 (test-assert "same input twice"
 181   (let ((exp (gexp (begin
 182                      (display (ungexp coreutils))
 183                      (display (ungexp coreutils))))))
 184     (and (gexp? exp)
 185          (match (gexp-inputs exp)
 186            (((p "out"))
 187             (eq? p coreutils)))
 188          (let ((e `(display ,(derivation->output-path
 189                               (package-derivation %store coreutils)))))
 190            (equal? `(begin ,e ,e) (gexp->sexp* exp))))))
 191
 192 (test-assert "two input packages, one derivation, one file"
 193   (let* ((drv (build-expression->derivation
 194                %store "foo" 'bar
 195                #:guile-for-build (package-derivation %store %bootstrap-guile)))
 196          (txt (add-text-to-store %store "foo" "Hello, world!"))
 197          (exp (gexp (begin
 198                       (display (ungexp coreutils))
 199                       (display (ungexp %bootstrap-guile))
 200                       (display (ungexp drv))
 201                       (display (ungexp txt))))))
 202     (define (match-input thing)
 203       (match-lambda
 204        ((drv-or-pkg _ ...)
 205         (eq? thing drv-or-pkg))))
 206
 207     (and (gexp? exp)
 208          (= 4 (length (gexp-inputs exp)))
 209          (every (lambda (input)
 210                   (find (match-input input) (gexp-inputs exp)))
 211                 (list drv coreutils %bootstrap-guile txt))
 212          (let ((e0 `(display ,(derivation->output-path
 213                                (package-derivation %store coreutils))))
 214                (e1 `(display ,(derivation->output-path
 215                                (package-derivation %store %bootstrap-guile))))
 216                (e2 `(display ,(derivation->output-path drv)))
 217                (e3 `(display ,txt)))
 218            (equal? `(begin ,e0 ,e1 ,e2 ,e3) (gexp->sexp* exp))))))
 219
 220 (test-assert "file-append"
 221   (let* ((drv (package-derivation %store %bootstrap-guile))
 222          (fa  (file-append %bootstrap-guile "/bin/guile"))
 223          (exp #~(here we go #$fa)))
 224     (and (match (gexp->sexp* exp)
 225            (('here 'we 'go (? string? result))
 226             (string=? result
 227                       (string-append (derivation->output-path drv)
 228                                      "/bin/guile"))))
 229          (match (gexp-inputs exp)
 230            (((thing "out"))
 231             (eq? thing fa))))))
 232
 233 (test-assert "file-append, output"
 234   (let* ((drv (package-derivation %store glibc))
 235          (fa  (file-append glibc "/lib" "/debug"))
 236          (exp #~(foo #$fa:debug)))
 237     (and (match (gexp->sexp* exp)
 238            (('foo (? string? result))
 239             (string=? result
 240                       (string-append (derivation->output-path drv "debug")
 241                                      "/lib/debug"))))
 242          (match (gexp-inputs exp)
 243            (((thing "debug"))
 244             (eq? thing fa))))))
 245
 246 (test-assert "file-append, nested"
 247   (let* ((drv   (package-derivation %store glibc))
 248          (dir   (file-append glibc "/bin"))
 249          (slash (file-append dir "/"))
 250          (file  (file-append slash "getent"))
 251          (exp   #~(foo #$file)))
 252     (and (match (gexp->sexp* exp)
 253            (('foo (? string? result))
 254             (string=? result
 255                       (string-append (derivation->output-path drv)
 256                                      "/bin/getent"))))
 257          (match (gexp-inputs exp)
 258            (((thing "out"))
 259             (eq? thing file))))))
 260
 261 (test-assert "ungexp + ungexp-native"
 262   (let* ((exp    (gexp (list (ungexp-native %bootstrap-guile)
 263                              (ungexp coreutils)
 264                              (ungexp-native glibc)
 265                              (ungexp binutils))))
 266          (target "mips64el-linux")
 267          (guile  (derivation->output-path
 268                   (package-derivation %store %bootstrap-guile)))
 269          (cu     (derivation->output-path
 270                   (package-cross-derivation %store coreutils target)))
 271          (libc   (derivation->output-path
 272                   (package-derivation %store glibc)))
 273          (bu     (derivation->output-path
 274                   (package-cross-derivation %store binutils target))))
 275     (and (lset= equal?
 276                 `((,%bootstrap-guile "out") (,glibc "out"))
 277                 (gexp-native-inputs exp))
 278          (lset= equal?
 279                 `((,coreutils "out") (,binutils "out"))
 280                 (gexp-inputs exp))
 281          (equal? `(list ,guile ,cu ,libc ,bu)
 282                  (gexp->sexp* exp target)))))
 283
 284 (test-equal "ungexp + ungexp-native, nested"
 285   (list `((,%bootstrap-guile "out")) '<> `((,coreutils "out")))
 286   (let* ((exp (gexp (list (ungexp-native (gexp (ungexp coreutils)))
 287                           (ungexp %bootstrap-guile)))))
 288     (list (gexp-inputs exp) '<> (gexp-native-inputs exp))))
 289
 290 (test-equal "ungexp + ungexp-native, nested, special mixture"
 291   `(() <> ((,coreutils "out")))
 292
 293   ;; (gexp-native-inputs exp) used to return '(), wrongfully.
 294   (let* ((foo (gexp (foo (ungexp-native coreutils))))
 295          (exp (gexp (bar (ungexp foo)))))
 296     (list (gexp-inputs exp) '<> (gexp-native-inputs exp))))
 297
 298 (test-assert "input list"
 299   (let ((exp   (gexp (display
 300                       '(ungexp (list %bootstrap-guile coreutils)))))
 301         (guile (derivation->output-path
 302                 (package-derivation %store %bootstrap-guile)))
 303         (cu    (derivation->output-path
 304                 (package-derivation %store coreutils))))
 305     (and (lset= equal?
 306                 `((,%bootstrap-guile "out") (,coreutils "out"))
 307                 (gexp-inputs exp))
 308          (equal? `(display '(,guile ,cu))
 309                  (gexp->sexp* exp)))))
 310
 311 (test-assert "input list + ungexp-native"
 312   (let* ((target "mips64el-linux")
 313          (exp   (gexp (display
 314                        (cons '(ungexp-native (list %bootstrap-guile coreutils))
 315                              '(ungexp (list glibc binutils))))))
 316          (guile (derivation->output-path
 317                  (package-derivation %store %bootstrap-guile)))
 318          (cu    (derivation->output-path
 319                  (package-derivation %store coreutils)))
 320          (xlibc (derivation->output-path
 321                  (package-cross-derivation %store glibc target)))
 322          (xbu   (derivation->output-path
 323                  (package-cross-derivation %store binutils target))))
 324     (and (lset= equal?
 325                 `((,%bootstrap-guile "out") (,coreutils "out"))
 326                 (gexp-native-inputs exp))
 327          (lset= equal?
 328                 `((,glibc "out") (,binutils "out"))
 329                 (gexp-inputs exp))
 330          (equal? `(display (cons '(,guile ,cu) '(,xlibc ,xbu)))
 331                  (gexp->sexp* exp target)))))
 332
 333 (test-assert "input list splicing"
 334   (let* ((inputs  (list (gexp-input glibc "debug") %bootstrap-guile))
 335          (outputs (list (derivation->output-path
 336                          (package-derivation %store glibc)
 337                          "debug")
 338                         (derivation->output-path
 339                          (package-derivation %store %bootstrap-guile))))
 340          (exp     (gexp (list (ungexp-splicing (cons (+ 2 3) inputs))))))
 341     (and (lset= equal?
 342                 `((,glibc "debug") (,%bootstrap-guile "out"))
 343                 (gexp-inputs exp))
 344          (equal? (gexp->sexp* exp)
 345                  `(list ,@(cons 5 outputs))))))
 346
 347 (test-assert "input list splicing + ungexp-native-splicing"
 348   (let* ((inputs (list (gexp-input glibc "debug" #:native? #t)
 349                        %bootstrap-guile))
 350          (exp    (gexp (list (ungexp-native-splicing (cons (+ 2 3) inputs))))))
 351     (and (lset= equal?
 352                 `((,glibc "debug") (,%bootstrap-guile "out"))
 353                 (gexp-native-inputs exp))
 354          (null? (gexp-inputs exp))
 355          (equal? (gexp->sexp* exp)                ;native
 356                  (gexp->sexp* exp "mips64el-linux")))))
 357
 358 (test-assert "gexp list splicing + ungexp-splicing"
 359   (let* ((inner (gexp (ungexp-native glibc)))
 360          (exp   (gexp (list (ungexp-splicing (list inner))))))
 361     (and (equal? `((,glibc "out")) (gexp-native-inputs exp))
 362          (null? (gexp-inputs exp))
 363          (equal? (gexp->sexp* exp)                ;native
 364                  (gexp->sexp* exp "mips64el-linux")))))
 365
 366 (test-equal "output list"
 367   2
 368   (let ((exp (gexp (begin (mkdir (ungexp output))
 369                           (mkdir (ungexp output "bar"))))))
 370     (length (gexp-outputs exp))))                ;XXX: <output-ref> is private
 371
 372 (test-assert "output list, combined gexps"
 373   (let* ((exp0  (gexp (mkdir (ungexp output))))
 374          (exp1  (gexp (mkdir (ungexp output "foo"))))
 375          (exp2  (gexp (begin (display "hi!") (ungexp exp0) (ungexp exp1)))))
 376     (and (lset= equal?
 377                 (append (gexp-outputs exp0) (gexp-outputs exp1))
 378                 (gexp-outputs exp2))
 379          (= 2 (length (gexp-outputs exp2))))))
 380
 381 (test-equal "output list, combined gexps, duplicate output"
 382   1
 383   (let* ((exp0 (gexp (mkdir (ungexp output))))
 384          (exp1 (gexp (begin (mkdir (ungexp output)) (ungexp exp0))))
 385          (exp2 (gexp (begin (mkdir (ungexp output)) (ungexp exp1)))))
 386     (length (gexp-outputs exp2))))
 387
 388 (test-assert "output list + ungexp-splicing list, combined gexps"
 389   (let* ((exp0  (gexp (mkdir (ungexp output))))
 390          (exp1  (gexp (mkdir (ungexp output "foo"))))
 391          (exp2  (gexp (begin (display "hi!")
 392                              (ungexp-splicing (list exp0 exp1))))))
 393     (and (lset= equal?
 394                 (append (gexp-outputs exp0) (gexp-outputs exp1))
 395                 (gexp-outputs exp2))
 396          (= 2 (length (gexp-outputs exp2))))))
 397
 398 (test-assertm "gexp->file"
 399   (mlet* %store-monad ((exp -> (gexp (display (ungexp %bootstrap-guile))))
 400                        (guile  (package-file %bootstrap-guile))
 401                        (sexp   (gexp->sexp exp))
 402                        (drv    (gexp->file "foo" exp))
 403                        (out -> (derivation->output-path drv))
 404                        (done   (built-derivations (list drv)))
 405                        (refs   (references* out)))
 406     (return (and (equal? sexp (call-with-input-file out read))
 407                  (equal? (list guile) refs)))))
 408
 409 (test-assertm "gexp->file + file-append"
 410   (mlet* %store-monad ((exp -> #~#$(file-append %bootstrap-guile
 411                                                 "/bin/guile"))
 412                        (guile  (package-file %bootstrap-guile))
 413                        (drv    (gexp->file "foo" exp))
 414                        (out -> (derivation->output-path drv))
 415                        (done   (built-derivations (list drv)))
 416                        (refs   (references* out)))
 417     (return (and (equal? (string-append guile "/bin/guile")
 418                          (call-with-input-file out read))
 419                  (equal? (list guile) refs)))))
 420
 421 (test-assertm "gexp->derivation"
 422   (mlet* %store-monad ((file    (text-file "foo" "Hello, world!"))
 423                        (exp ->  (gexp
 424                                  (begin
 425                                    (mkdir (ungexp output))
 426                                    (chdir (ungexp output))
 427                                    (symlink
 428                                     (string-append (ungexp %bootstrap-guile)
 429                                                    "/bin/guile")
 430                                     "foo")
 431                                    (symlink (ungexp file)
 432                                             (ungexp output "2nd")))))
 433                        (drv     (gexp->derivation "foo" exp))
 434                        (out ->  (derivation->output-path drv))
 435                        (out2 -> (derivation->output-path drv "2nd"))
 436                        (done    (built-derivations (list drv)))
 437                        (refs    (references* out))
 438                        (refs2   (references* out2))
 439                        (guile   (package-file %bootstrap-guile "bin/guile")))
 440     (return (and (string=? (readlink (string-append out "/foo")) guile)
 441                  (string=? (readlink out2) file)
 442                  (equal? refs (list (dirname (dirname guile))))
 443                  (equal? refs2 (list file))))))
 444
 445 (test-assertm "gexp->derivation vs. grafts"
 446   (mlet* %store-monad ((graft?  (set-grafting #f))
 447                        (p0 ->   (dummy-package "dummy"
 448                                                (arguments
 449                                                 '(#:implicit-inputs? #f))))
 450                        (r  ->   (package (inherit p0) (name "DuMMY")))
 451                        (p1 ->   (package (inherit p0) (replacement r)))
 452                        (exp0 -> (gexp (frob (ungexp p0) (ungexp output))))
 453                        (exp1 -> (gexp (frob (ungexp p1) (ungexp output))))
 454                        (void    (set-guile-for-build %bootstrap-guile))
 455                        (drv0    (gexp->derivation "t" exp0 #:graft? #t))
 456                        (drv1    (gexp->derivation "t" exp1 #:graft? #t))
 457                        (drv1*   (gexp->derivation "t" exp1 #:graft? #f))
 458                        (_       (set-grafting graft?)))
 459     (return (and (not (string=? (derivation->output-path drv0)
 460                                 (derivation->output-path drv1)))
 461                  (string=? (derivation->output-path drv0)
 462                            (derivation->output-path drv1*))))))
 463
 464 (test-assertm "gexp->derivation, composed gexps"
 465   (mlet* %store-monad ((exp0 -> (gexp (begin
 466                                         (mkdir (ungexp output))
 467                                         (chdir (ungexp output)))))
 468                        (exp1 -> (gexp (symlink
 469                                        (string-append (ungexp %bootstrap-guile)
 470                                                       "/bin/guile")
 471                                        "foo")))
 472                        (exp  -> (gexp (begin (ungexp exp0) (ungexp exp1))))
 473                        (drv     (gexp->derivation "foo" exp))
 474                        (out ->  (derivation->output-path drv))
 475                        (done    (built-derivations (list drv)))
 476                        (guile   (package-file %bootstrap-guile "bin/guile")))
 477     (return (string=? (readlink (string-append out "/foo"))
 478                       guile))))
 479
 480 (test-assertm "gexp->derivation, default system"
 481   ;; The default system should be the one at '>>=' time, not the one at
 482   ;; invocation time.  See <http://bugs.gnu.org/18002>.
 483   (let ((system (%current-system))
 484         (mdrv   (parameterize ((%current-system "foobar64-linux"))
 485                   (gexp->derivation "foo"
 486                                     (gexp
 487                                      (mkdir (ungexp output)))))))
 488     (mlet %store-monad ((drv mdrv))
 489       (return (string=? system (derivation-system drv))))))
 490
 491 (test-assertm "gexp->derivation, local-file"
 492   (mlet* %store-monad ((file ->  (search-path %load-path "guix.scm"))
 493                        (intd     (interned-file file #:recursive? #f))
 494                        (local -> (local-file file))
 495                        (exp ->   (gexp (begin
 496                                          (stat (ungexp local))
 497                                          (symlink (ungexp local)
 498                                                   (ungexp output)))))
 499                        (drv      (gexp->derivation "local-file" exp)))
 500     (mbegin %store-monad
 501       (built-derivations (list drv))
 502       (return (string=? (readlink (derivation->output-path drv))
 503                         intd)))))
 504
 505 (test-assertm "gexp->derivation, cross-compilation"
 506   (mlet* %store-monad ((target -> "mips64el-linux")
 507                        (exp    -> (gexp (list (ungexp coreutils)
 508                                               (ungexp output))))
 509                        (xdrv      (gexp->derivation "foo" exp
 510                                                     #:target target))
 511                        (refs      (references*
 512                                    (derivation-file-name xdrv)))
 513                        (xcu       (package->cross-derivation coreutils
 514                                                              target))
 515                        (cu        (package->derivation coreutils)))
 516     (return (and (member (derivation-file-name xcu) refs)
 517                  (not (member (derivation-file-name cu) refs))))))
 518
 519 (test-assertm "gexp->derivation, ungexp-native"
 520   (mlet* %store-monad ((target -> "mips64el-linux")
 521                        (exp    -> (gexp (list (ungexp-native coreutils)
 522                                               (ungexp output))))
 523                        (xdrv      (gexp->derivation "foo" exp
 524                                                     #:target target))
 525                        (drv       (gexp->derivation "foo" exp)))
 526     (return (string=? (derivation-file-name drv)
 527                       (derivation-file-name xdrv)))))
 528
 529 (test-assertm "gexp->derivation, ungexp + ungexp-native"
 530   (mlet* %store-monad ((target -> "mips64el-linux")
 531                        (exp    -> (gexp (list (ungexp-native coreutils)
 532                                               (ungexp glibc)
 533                                               (ungexp output))))
 534                        (xdrv      (gexp->derivation "foo" exp
 535                                                     #:target target))
 536                        (refs      (references*
 537                                    (derivation-file-name xdrv)))
 538                        (xglibc    (package->cross-derivation glibc target))
 539                        (cu        (package->derivation coreutils)))
 540     (return (and (member (derivation-file-name cu) refs)
 541                  (member (derivation-file-name xglibc) refs)))))
 542
 543 (test-assertm "gexp->derivation, ungexp-native + composed gexps"
 544   (mlet* %store-monad ((target -> "mips64el-linux")
 545                        (exp0   -> (gexp (list 1 2
 546                                               (ungexp coreutils))))
 547                        (exp    -> (gexp (list 0 (ungexp-native exp0))))
 548                        (xdrv      (gexp->derivation "foo" exp
 549                                                     #:target target))
 550                        (drv       (gexp->derivation "foo" exp)))
 551     (return (string=? (derivation-file-name drv)
 552                       (derivation-file-name xdrv)))))
 553
 554 (test-assertm "gexp->derivation, store copy"
 555   (let ((build-one #~(call-with-output-file #$output
 556                        (lambda (port)
 557                          (display "This is the one." port))))
 558         (build-two (lambda (one)
 559                      #~(begin
 560                          (mkdir #$output)
 561                          (symlink #$one (string-append #$output "/one"))
 562                          (call-with-output-file (string-append #$output "/two")
 563                            (lambda (port)
 564                              (display "This is the second one." port))))))
 565         (build-drv #~(begin
 566                        (use-modules (guix build store-copy))
 567
 568                        (mkdir #$output)
 569                        (populate-store '("graph") #$output))))
 570     (mlet* %store-monad ((one (gexp->derivation "one" build-one))
 571                          (two (gexp->derivation "two" (build-two one)))
 572                          (drv (gexp->derivation "store-copy" build-drv
 573                                                 #:references-graphs
 574                                                 `(("graph" ,two))
 575                                                 #:modules
 576                                                 '((guix build store-copy)
 577                                                   (guix build utils))))
 578                          (ok? (built-derivations (list drv)))
 579                          (out -> (derivation->output-path drv)))
 580       (let ((one (derivation->output-path one))
 581             (two (derivation->output-path two)))
 582         (return (and ok?
 583                      (file-exists? (string-append out "/" one))
 584                      (file-exists? (string-append out "/" two))
 585                      (file-exists? (string-append out "/" two "/two"))
 586                      (string=? (readlink (string-append out "/" two "/one"))
 587                                one)))))))
 588
 589 (test-assertm "imported-files"
 590   (mlet* %store-monad
 591       ((files -> `(("x"     . ,(search-path %load-path "ice-9/q.scm"))
 592                    ("a/b/c" . ,(search-path %load-path
 593                                             "guix/derivations.scm"))
 594                    ("p/q"   . ,(search-path %load-path "guix.scm"))
 595                    ("p/z"   . ,(search-path %load-path "guix/store.scm"))))
 596        (drv (imported-files files)))
 597     (mbegin %store-monad
 598       (built-derivations (list drv))
 599       (let ((dir (derivation->output-path drv)))
 600         (return
 601          (every (match-lambda
 602                  ((path . source)
 603                   (equal? (call-with-input-file (string-append dir "/" path)
 604                             get-bytevector-all)
 605                           (call-with-input-file source
 606                             get-bytevector-all))))
 607                 files))))))
 608
 609 (test-assertm "imported-files with file-like objects"
 610   (mlet* %store-monad ((plain -> (plain-file "foo" "bar!"))
 611                        (q-scm -> (search-path %load-path "ice-9/q.scm"))
 612                        (files -> `(("a/b/c" . ,q-scm)
 613                                    ("p/q"   . ,plain)))
 614                        (drv      (imported-files files)))
 615     (mbegin %store-monad
 616       (built-derivations (list drv))
 617       (mlet %store-monad ((dir -> (derivation->output-path drv))
 618                           (plain* (text-file "foo" "bar!"))
 619                           (q-scm* (interned-file q-scm "c")))
 620         (return
 621          (and (string=? (readlink (string-append dir "/a/b/c"))
 622                         q-scm*)
 623               (string=? (readlink (string-append dir "/p/q"))
 624                         plain*)))))))
 625
 626 (test-equal "gexp-modules & ungexp"
 627   '((bar) (foo))
 628   ((@@ (guix gexp) gexp-modules)
 629    #~(foo #$(with-imported-modules '((foo)) #~+)
 630           #+(with-imported-modules '((bar)) #~-))))
 631
 632 (test-equal "gexp-modules & ungexp-splicing"
 633   '((foo) (bar))
 634   ((@@ (guix gexp) gexp-modules)
 635    #~(foo #$@(list (with-imported-modules '((foo)) #~+)
 636                    (with-imported-modules '((bar)) #~-)))))
 637
 638 (test-equal "gexp-modules and literal Scheme object"
 639   '()
 640   (gexp-modules #t))
 641
 642 (test-assertm "gexp->derivation #:modules"
 643   (mlet* %store-monad
 644       ((build ->  #~(begin
 645                       (use-modules (guix build utils))
 646                       (mkdir-p (string-append #$output "/guile/guix/nix"))
 647                       #t))
 648        (drv       (gexp->derivation "test-with-modules" build
 649                                     #:modules '((guix build utils)))))
 650     (mbegin %store-monad
 651       (built-derivations (list drv))
 652       (let* ((p (derivation->output-path drv))
 653              (s (stat (string-append p "/guile/guix/nix"))))
 654         (return (eq? (stat:type s) 'directory))))))
 655
 656 (test-assertm "gexp->derivation & with-imported-modules"
 657   ;; Same test as above, but using 'with-imported-modules'.
 658   (mlet* %store-monad
 659       ((build ->  (with-imported-modules '((guix build utils))
 660                     #~(begin
 661                         (use-modules (guix build utils))
 662                         (mkdir-p (string-append #$output "/guile/guix/nix"))
 663                         #t)))
 664        (drv       (gexp->derivation "test-with-modules" build)))
 665     (mbegin %store-monad
 666       (built-derivations (list drv))
 667       (let* ((p (derivation->output-path drv))
 668              (s (stat (string-append p "/guile/guix/nix"))))
 669         (return (eq? (stat:type s) 'directory))))))
 670
 671 (test-assertm "gexp->derivation & nested with-imported-modules"
 672   (mlet* %store-monad
 673       ((build1 ->  (with-imported-modules '((guix build utils))
 674                      #~(begin
 675                          (use-modules (guix build utils))
 676                          (mkdir-p (string-append #$output "/guile/guix/nix"))
 677                          #t)))
 678        (build2 ->  (with-imported-modules '((guix build bournish))
 679                      #~(begin
 680                          (use-modules (guix build bournish)
 681                                       (system base compile))
 682                          #+build1
 683                          (call-with-output-file (string-append #$output "/b")
 684                            (lambda (port)
 685                              (write
 686                               (read-and-compile (open-input-string "cd /foo")
 687                                                 #:from %bournish-language
 688                                                 #:to 'scheme)
 689                               port))))))
 690        (drv        (gexp->derivation "test-with-modules" build2)))
 691     (mbegin %store-monad
 692       (built-derivations (list drv))
 693       (let* ((p (derivation->output-path drv))
 694              (s (stat (string-append p "/guile/guix/nix")))
 695              (b (string-append p "/b")))
 696         (return (and (eq? (stat:type s) 'directory)
 697                      (equal? '(chdir "/foo")
 698                              (call-with-input-file b read))))))))
 699
 700 (test-assertm "gexp->derivation & with-imported-module & computed module"
 701   (mlet* %store-monad
 702       ((module -> (scheme-file "x" #~(begin
 703                                        (define-module (foo bar)
 704                                          #:export (the-answer))
 705
 706                                        (define the-answer 42))))
 707        (build -> (with-imported-modules `(((foo bar) => ,module)
 708                                           (guix build utils))
 709                    #~(begin
 710                        (use-modules (guix build utils)
 711                                     (foo bar))
 712                        mkdir-p
 713                        (call-with-output-file #$output
 714                          (lambda (port)
 715                            (write the-answer port))))))
 716        (drv      (gexp->derivation "thing" build))
 717        (out ->   (derivation->output-path drv)))
 718     (mbegin %store-monad
 719       (built-derivations (list drv))
 720       (return (= 42 (call-with-input-file out read))))))
 721
 722 (test-assertm "gexp->derivation #:references-graphs"
 723   (mlet* %store-monad
 724       ((one (text-file "one" (random-text)))
 725        (two (gexp->derivation "two"
 726                               #~(symlink #$one #$output:chbouib)))
 727        (build -> (with-imported-modules '((guix build store-copy)
 728                                           (guix build utils))
 729                    #~(begin
 730                        (use-modules (guix build store-copy))
 731                        (with-output-to-file #$output
 732                          (lambda ()
 733                            (write (call-with-input-file "guile"
 734                                     read-reference-graph))))
 735                        (with-output-to-file #$output:one
 736                          (lambda ()
 737                            (write (call-with-input-file "one"
 738                                     read-reference-graph))))
 739                        (with-output-to-file #$output:two
 740                          (lambda ()
 741                            (write (call-with-input-file "two"
 742                                     read-reference-graph)))))))
 743        (drv (gexp->derivation "ref-graphs" build
 744                               #:references-graphs `(("one" ,one)
 745                                                     ("two" ,two "chbouib")
 746                                                     ("guile" ,%bootstrap-guile))))
 747        (ok? (built-derivations (list drv)))
 748        (guile-drv  (package->derivation %bootstrap-guile))
 749        (bash       (interned-file (search-bootstrap-binary "bash"
 750                                                            (%current-system))
 751                                   "bash" #:recursive? #t))
 752        (g-one   -> (derivation->output-path drv "one"))
 753        (g-two   -> (derivation->output-path drv "two"))
 754        (g-guile -> (derivation->output-path drv)))
 755     (return (and ok?
 756                  (equal? (call-with-input-file g-one read) (list one))
 757                  (lset= string=?
 758                         (call-with-input-file g-two read)
 759                         (list one (derivation->output-path two "chbouib")))
 760
 761                  ;; Note: %BOOTSTRAP-GUILE depends on the bootstrap Bash.
 762                  (lset= string=?
 763                         (call-with-input-file g-guile read)
 764                         (list (derivation->output-path guile-drv) bash))))))
 765
 766 (test-assertm "gexp->derivation #:allowed-references"
 767   (mlet %store-monad ((drv (gexp->derivation "allowed-refs"
 768                                              #~(begin
 769                                                  (mkdir #$output)
 770                                                  (chdir #$output)
 771                                                  (symlink #$output "self")
 772                                                  (symlink #$%bootstrap-guile
 773                                                           "guile"))
 774                                              #:allowed-references
 775                                              (list "out" %bootstrap-guile))))
 776     (built-derivations (list drv))))
 777
 778 (test-assertm "gexp->derivation #:allowed-references, specific output"
 779   (mlet* %store-monad ((in  (gexp->derivation "thing"
 780                                               #~(begin
 781                                                   (mkdir #$output:ok)
 782                                                   (mkdir #$output:not-ok))))
 783                        (drv (gexp->derivation "allowed-refs"
 784                                               #~(begin
 785                                                   (pk #$in:not-ok)
 786                                                   (mkdir #$output)
 787                                                   (chdir #$output)
 788                                                   (symlink #$output "self")
 789                                                   (symlink #$in:ok "ok"))
 790                                               #:allowed-references
 791                                               (list "out"
 792                                                     (gexp-input in "ok")))))
 793     (built-derivations (list drv))))
 794
 795 (test-assert "gexp->derivation #:allowed-references, disallowed"
 796   (let ((drv (run-with-store %store
 797                (gexp->derivation "allowed-refs"
 798                                  #~(begin
 799                                      (mkdir #$output)
 800                                      (chdir #$output)
 801                                      (symlink #$%bootstrap-guile "guile"))
 802                                  #:allowed-references '()))))
 803     (guard (c ((nix-protocol-error? c) #t))
 804       (build-derivations %store (list drv))
 805       #f)))
 806
 807 (test-assertm "gexp->derivation #:disallowed-references, allowed"
 808   (mlet %store-monad ((drv (gexp->derivation "disallowed-refs"
 809                                              #~(begin
 810                                                  (mkdir #$output)
 811                                                  (chdir #$output)
 812                                                  (symlink #$output "self")
 813                                                  (symlink #$%bootstrap-guile
 814                                                           "guile"))
 815                                              #:disallowed-references '())))
 816     (built-derivations (list drv))))
 817
 818
 819 (test-assert "gexp->derivation #:disallowed-references"
 820   (let ((drv (run-with-store %store
 821                (gexp->derivation "disallowed-refs"
 822                                  #~(begin
 823                                      (mkdir #$output)
 824                                      (chdir #$output)
 825                                      (symlink #$%bootstrap-guile "guile"))
 826                                  #:disallowed-references (list %bootstrap-guile)))))
 827     (guard (c ((nix-protocol-error? c) #t))
 828       (build-derivations %store (list drv))
 829       #f)))
 830
 831 (define shebang
 832   (string-append "#!" (derivation->output-path (%guile-for-build))
 833                  "/bin/guile --no-auto-compile"))
 834
 835 ;; If we're going to hit the silly shebang limit (128 chars on Linux-based
 836 ;; systems), then skip the following test.
 837 (test-skip (if (> (string-length shebang) 127) 2 0))
 838
 839 (test-assertm "gexp->script"
 840   (mlet* %store-monad ((n ->   (random (expt 2 50)))
 841                        (exp -> (gexp
 842                                 (system*
 843                                  (string-append (ungexp %bootstrap-guile)
 844                                                 "/bin/guile")
 845                                  "-c" (object->string
 846                                        '(display (expt (ungexp n) 2))))))
 847                        (drv    (gexp->script "guile-thing" exp
 848                                              #:guile %bootstrap-guile))
 849                        (out -> (derivation->output-path drv))
 850                        (done   (built-derivations (list drv))))
 851     (let* ((pipe  (open-input-pipe out))
 852            (str   (get-string-all pipe)))
 853       (return (and (zero? (close-pipe pipe))
 854                    (= (expt n 2) (string->number str)))))))
 855
 856 (test-assertm "program-file"
 857   (let* ((n      (random (expt 2 50)))
 858          (exp    (with-imported-modules '((guix build utils))
 859                    (gexp (begin
 860                            (use-modules (guix build utils))
 861                            (display (ungexp n))))))
 862          (file   (program-file "program" exp
 863                                #:guile %bootstrap-guile)))
 864     (mlet* %store-monad ((drv (lower-object file))
 865                          (out -> (derivation->output-path drv)))
 866       (mbegin %store-monad
 867         (built-derivations (list drv))
 868         (let* ((pipe  (open-input-pipe out))
 869                (str   (get-string-all pipe)))
 870           (return (and (zero? (close-pipe pipe))
 871                        (= n (string->number str)))))))))
 872
 873 (test-assertm "scheme-file"
 874   (let* ((text   (plain-file "foo" "Hello, world!"))
 875          (scheme (scheme-file "bar" #~(list "foo" #$text))))
 876     (mlet* %store-monad ((drv  (lower-object scheme))
 877                          (text (lower-object text))
 878                          (out -> (derivation->output-path drv)))
 879       (mbegin %store-monad
 880         (built-derivations (list drv))
 881         (mlet %store-monad ((refs (references* out)))
 882           (return (and (equal? refs (list text))
 883                        (equal? `(list "foo" ,text)
 884                                (call-with-input-file out read)))))))))
 885
 886 (test-assert "text-file*"
 887   (run-with-store %store
 888     (mlet* %store-monad
 889         ((drv  (package->derivation %bootstrap-guile))
 890          (guile -> (derivation->output-path drv))
 891          (file (text-file "bar" "This is bar."))
 892          (text (text-file* "foo"
 893                            %bootstrap-guile "/bin/guile "
 894                            (gexp-input %bootstrap-guile "out") "/bin/guile "
 895                            drv "/bin/guile "
 896                            file))
 897          (done (built-derivations (list text)))
 898          (out -> (derivation->output-path text))
 899          (refs (references* out)))
 900       ;; Make sure we get the right references and the right content.
 901       (return (and (lset= string=? refs (list guile file))
 902                    (equal? (call-with-input-file out get-string-all)
 903                            (string-append guile "/bin/guile "
 904                                           guile "/bin/guile "
 905                                           guile "/bin/guile "
 906                                           file)))))
 907     #:guile-for-build (package-derivation %store %bootstrap-guile)))
 908
 909 (test-assertm "mixed-text-file"
 910   (mlet* %store-monad ((file ->   (mixed-text-file "mixed"
 911                                                    "export PATH="
 912                                                    %bootstrap-guile "/bin"))
 913                        (drv       (lower-object file))
 914                        (out ->    (derivation->output-path drv))
 915                        (guile-drv (package->derivation %bootstrap-guile))
 916                        (guile ->  (derivation->output-path guile-drv)))
 917     (mbegin %store-monad
 918       (built-derivations (list drv))
 919       (mlet %store-monad ((refs (references* out)))
 920         (return (and (string=? (string-append "export PATH=" guile "/bin")
 921                                (call-with-input-file out get-string-all))
 922                      (equal? refs (list guile))))))))
 923
 924 (test-assert "gexp->derivation vs. %current-target-system"
 925   (let ((mval (gexp->derivation "foo"
 926                                 #~(begin
 927                                     (mkdir #$output)
 928                                     (foo #+gnu-make))
 929                                 #:target #f)))
 930     ;; The value of %CURRENT-TARGET-SYSTEM at bind-time should have no
 931     ;; influence.
 932     (parameterize ((%current-target-system "fooooo"))
 933       (derivation? (run-with-store %store mval)))))
 934
 935 (test-assertm "lower-object"
 936   (mlet %store-monad ((drv1 (lower-object %bootstrap-guile))
 937                       (drv2 (lower-object (package-source coreutils)))
 938                       (item (lower-object (plain-file "foo" "Hello!"))))
 939     (return (and (derivation? drv1) (derivation? drv2)
 940                  (store-path? item)))))
 941
 942 (test-assertm "lower-object, computed-file"
 943   (let* ((text     (plain-file "foo" "Hello!"))
 944          (exp      #~(begin
 945                        (mkdir #$output)
 946                        (symlink #$%bootstrap-guile
 947                                 (string-append #$output "/guile"))
 948                        (symlink #$text (string-append #$output "/text"))))
 949          (computed (computed-file "computed" exp)))
 950     (mlet* %store-monad ((text      (lower-object text))
 951                          (guile-drv (lower-object %bootstrap-guile))
 952                          (comp-drv  (lower-object computed))
 953                          (comp ->   (derivation->output-path comp-drv)))
 954       (mbegin %store-monad
 955         (built-derivations (list comp-drv))
 956         (return (and (string=? (readlink (string-append comp "/guile"))
 957                                (derivation->output-path guile-drv))
 958                      (string=? (readlink (string-append comp "/text"))
 959                                text)))))))
 960
 961 (test-assert "lower-object & gexp-input-error?"
 962   (guard (c ((gexp-input-error? c)
 963              (gexp-error-invalid-input c)))
 964     (run-with-store %store
 965       (lower-object (current-module))
 966       #:guile-for-build (%guile-for-build))))
 967
 968 (test-assert "printer"
 969   (string-match "^#<gexp \\(string-append .*#<package coreutils.*\
 970  \"/bin/uname\"\\) [[:xdigit:]]+>$"
 971                 (with-output-to-string
 972                   (lambda ()
 973                     (write
 974                      (gexp (string-append (ungexp coreutils)
 975                                           "/bin/uname")))))))
 976
 977 (test-assert "printer vs. ungexp-splicing"
 978   (string-match "^#<gexp .* [[:xdigit:]]+>$"
 979                 (with-output-to-string
 980                   (lambda ()
 981                     ;; #~(begin #$@#~())
 982                     (write
 983                      (gexp (begin (ungexp-splicing (gexp ())))))))))
 984
 985 (test-equal "sugar"
 986   '(gexp (foo (ungexp bar) (ungexp baz "out")
 987               (ungexp (chbouib 42))
 988               (ungexp-splicing (list x y z))
 989               (ungexp-native foo) (ungexp-native foo "out")
 990               (ungexp-native (chbouib 42))
 991               (ungexp-native-splicing (list x y z))))
 992   '#~(foo #$bar #$baz:out #$(chbouib 42) #$@(list x y z)
 993           #+foo #+foo:out #+(chbouib 42) #+@(list x y z)))
 994
 995 (test-end "gexp")
 996
 997 ;; Local Variables:
 998 ;; eval: (put 'test-assertm 'scheme-indent-function 1)
 999 ;; End: