tests/gexp.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2015 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 derivations)
  24   #:use-module (guix packages)
  25   #:use-module (guix tests)
  26   #:use-module (gnu packages)
  27   #:use-module (gnu packages base)
  28   #:use-module (gnu packages bootstrap)
  29   #:use-module (srfi srfi-1)
  30   #:use-module (srfi srfi-34)
  31   #:use-module (srfi srfi-64)
  32   #:use-module (rnrs io ports)
  33   #:use-module (ice-9 match)
  34   #:use-module (ice-9 regex)
  35   #:use-module (ice-9 popen))
  36
  37 ;; Test the (guix gexp) module.
  38
  39 (define %store
  40   (open-connection-for-tests))
  41
  42 ;; For white-box testing.
  43 (define (gexp-inputs x)
  44   ((@@ (guix gexp) gexp-inputs) x))
  45 (define (gexp-native-inputs x)
  46   ((@@ (guix gexp) gexp-native-inputs) x))
  47 (define (gexp-outputs x)
  48   ((@@ (guix gexp) gexp-outputs) x))
  49 (define (gexp->sexp . x)
  50   (apply (@@ (guix gexp) gexp->sexp) x))
  51
  52 (define* (gexp->sexp* exp #:optional target)
  53   (run-with-store %store (gexp->sexp exp
  54                                      #:target target)
  55                   #:guile-for-build (%guile-for-build)))
  56
  57 (define-syntax-rule (test-assertm name exp)
  58   (test-assert name
  59     (run-with-store %store exp
  60                     #:guile-for-build (%guile-for-build))))
  61
  62 \f
  63 (test-begin "gexp")
  64
  65 (test-equal "no refs"
  66   '(display "hello!")
  67   (let ((exp (gexp (display "hello!"))))
  68     (and (gexp? exp)
  69          (null? (gexp-inputs exp))
  70          (gexp->sexp* exp))))
  71
  72 (test-equal "unquote"
  73   '(display `(foo ,(+ 2 3)))
  74   (let ((exp (gexp (display `(foo ,(+ 2 3))))))
  75     (and (gexp? exp)
  76          (null? (gexp-inputs exp))
  77          (gexp->sexp* exp))))
  78
  79 (test-assert "one input package"
  80   (let ((exp (gexp (display (ungexp coreutils)))))
  81     (and (gexp? exp)
  82          (match (gexp-inputs exp)
  83            (((p "out"))
  84             (eq? p coreutils)))
  85          (equal? `(display ,(derivation->output-path
  86                              (package-derivation %store coreutils)))
  87                  (gexp->sexp* exp)))))
  88
  89 (test-assert "one input origin"
  90   (let ((exp (gexp (display (ungexp (package-source coreutils))))))
  91     (and (gexp? exp)
  92          (match (gexp-inputs exp)
  93            (((o "out"))
  94             (eq? o (package-source coreutils))))
  95          (equal? `(display ,(derivation->output-path
  96                              (package-source-derivation
  97                               %store (package-source coreutils))))
  98                  (gexp->sexp* exp)))))
  99
 100 (test-assert "one local file"
 101   (let* ((file  (search-path %load-path "guix.scm"))
 102          (local (local-file file))
 103          (exp   (gexp (display (ungexp local))))
 104          (intd  (add-to-store %store (basename file) #f
 105                               "sha256" file)))
 106     (and (gexp? exp)
 107          (match (gexp-inputs exp)
 108            (((x "out"))
 109             (eq? x local)))
 110          (equal? `(display ,intd) (gexp->sexp* exp)))))
 111
 112 (test-assert "one local file, symlink"
 113   (let ((file (search-path %load-path "guix.scm"))
 114         (link (tmpnam)))
 115     (dynamic-wind
 116       (const #t)
 117       (lambda ()
 118         (symlink (canonicalize-path file) link)
 119         (let* ((local (local-file link "my-file" #:recursive? #f))
 120                (exp   (gexp (display (ungexp local))))
 121                (intd  (add-to-store %store "my-file" #f
 122                                     "sha256" file)))
 123           (and (gexp? exp)
 124                (match (gexp-inputs exp)
 125                  (((x "out"))
 126                   (eq? x local)))
 127                (equal? `(display ,intd) (gexp->sexp* exp)))))
 128       (lambda ()
 129         (false-if-exception (delete-file link))))))
 130
 131 (test-assert "one plain file"
 132   (let* ((file     (plain-file "hi" "Hello, world!"))
 133          (exp      (gexp (display (ungexp file))))
 134          (expected (add-text-to-store %store "hi" "Hello, world!")))
 135     (and (gexp? exp)
 136          (match (gexp-inputs exp)
 137            (((x "out"))
 138             (eq? x file)))
 139          (equal? `(display ,expected) (gexp->sexp* exp)))))
 140
 141 (test-assert "same input twice"
 142   (let ((exp (gexp (begin
 143                      (display (ungexp coreutils))
 144                      (display (ungexp coreutils))))))
 145     (and (gexp? exp)
 146          (match (gexp-inputs exp)
 147            (((p "out"))
 148             (eq? p coreutils)))
 149          (let ((e `(display ,(derivation->output-path
 150                               (package-derivation %store coreutils)))))
 151            (equal? `(begin ,e ,e) (gexp->sexp* exp))))))
 152
 153 (test-assert "two input packages, one derivation, one file"
 154   (let* ((drv (build-expression->derivation
 155                %store "foo" 'bar
 156                #:guile-for-build (package-derivation %store %bootstrap-guile)))
 157          (txt (add-text-to-store %store "foo" "Hello, world!"))
 158          (exp (gexp (begin
 159                       (display (ungexp coreutils))
 160                       (display (ungexp %bootstrap-guile))
 161                       (display (ungexp drv))
 162                       (display (ungexp txt))))))
 163     (define (match-input thing)
 164       (match-lambda
 165        ((drv-or-pkg _ ...)
 166         (eq? thing drv-or-pkg))))
 167
 168     (and (gexp? exp)
 169          (= 4 (length (gexp-inputs exp)))
 170          (every (lambda (input)
 171                   (find (match-input input) (gexp-inputs exp)))
 172                 (list drv coreutils %bootstrap-guile txt))
 173          (let ((e0 `(display ,(derivation->output-path
 174                                (package-derivation %store coreutils))))
 175                (e1 `(display ,(derivation->output-path
 176                                (package-derivation %store %bootstrap-guile))))
 177                (e2 `(display ,(derivation->output-path drv)))
 178                (e3 `(display ,txt)))
 179            (equal? `(begin ,e0 ,e1 ,e2 ,e3) (gexp->sexp* exp))))))
 180
 181 (test-assert "ungexp + ungexp-native"
 182   (let* ((exp    (gexp (list (ungexp-native %bootstrap-guile)
 183                              (ungexp coreutils)
 184                              (ungexp-native glibc)
 185                              (ungexp binutils))))
 186          (target "mips64el-linux")
 187          (guile  (derivation->output-path
 188                   (package-derivation %store %bootstrap-guile)))
 189          (cu     (derivation->output-path
 190                   (package-cross-derivation %store coreutils target)))
 191          (libc   (derivation->output-path
 192                   (package-derivation %store glibc)))
 193          (bu     (derivation->output-path
 194                   (package-cross-derivation %store binutils target))))
 195     (and (lset= equal?
 196                 `((,%bootstrap-guile "out") (,glibc "out"))
 197                 (gexp-native-inputs exp))
 198          (lset= equal?
 199                 `((,coreutils "out") (,binutils "out"))
 200                 (gexp-inputs exp))
 201          (equal? `(list ,guile ,cu ,libc ,bu)
 202                  (gexp->sexp* exp target)))))
 203
 204 (test-equal "ungexp + ungexp-native, nested"
 205   (list `((,%bootstrap-guile "out")) '<> `((,coreutils "out")))
 206   (let* ((exp (gexp (list (ungexp-native (gexp (ungexp coreutils)))
 207                           (ungexp %bootstrap-guile)))))
 208     (list (gexp-inputs exp) '<> (gexp-native-inputs exp))))
 209
 210 (test-assert "input list"
 211   (let ((exp   (gexp (display
 212                       '(ungexp (list %bootstrap-guile coreutils)))))
 213         (guile (derivation->output-path
 214                 (package-derivation %store %bootstrap-guile)))
 215         (cu    (derivation->output-path
 216                 (package-derivation %store coreutils))))
 217     (and (lset= equal?
 218                 `((,%bootstrap-guile "out") (,coreutils "out"))
 219                 (gexp-inputs exp))
 220          (equal? `(display '(,guile ,cu))
 221                  (gexp->sexp* exp)))))
 222
 223 (test-assert "input list + ungexp-native"
 224   (let* ((target "mips64el-linux")
 225          (exp   (gexp (display
 226                        (cons '(ungexp-native (list %bootstrap-guile coreutils))
 227                              '(ungexp (list glibc binutils))))))
 228          (guile (derivation->output-path
 229                  (package-derivation %store %bootstrap-guile)))
 230          (cu    (derivation->output-path
 231                  (package-derivation %store coreutils)))
 232          (xlibc (derivation->output-path
 233                  (package-cross-derivation %store glibc target)))
 234          (xbu   (derivation->output-path
 235                  (package-cross-derivation %store binutils target))))
 236     (and (lset= equal?
 237                 `((,%bootstrap-guile "out") (,coreutils "out"))
 238                 (gexp-native-inputs exp))
 239          (lset= equal?
 240                 `((,glibc "out") (,binutils "out"))
 241                 (gexp-inputs exp))
 242          (equal? `(display (cons '(,guile ,cu) '(,xlibc ,xbu)))
 243                  (gexp->sexp* exp target)))))
 244
 245 (test-assert "input list splicing"
 246   (let* ((inputs  (list (gexp-input glibc "debug") %bootstrap-guile))
 247          (outputs (list (derivation->output-path
 248                          (package-derivation %store glibc)
 249                          "debug")
 250                         (derivation->output-path
 251                          (package-derivation %store %bootstrap-guile))))
 252          (exp     (gexp (list (ungexp-splicing (cons (+ 2 3) inputs))))))
 253     (and (lset= equal?
 254                 `((,glibc "debug") (,%bootstrap-guile "out"))
 255                 (gexp-inputs exp))
 256          (equal? (gexp->sexp* exp)
 257                  `(list ,@(cons 5 outputs))))))
 258
 259 (test-assert "input list splicing + ungexp-native-splicing"
 260   (let* ((inputs (list (gexp-input glibc "debug") %bootstrap-guile))
 261          (exp    (gexp (list (ungexp-native-splicing (cons (+ 2 3) inputs))))))
 262     (and (lset= equal?
 263                 `((,glibc "debug") (,%bootstrap-guile "out"))
 264                 (gexp-native-inputs exp))
 265          (null? (gexp-inputs exp))
 266          (equal? (gexp->sexp* exp)                ;native
 267                  (gexp->sexp* exp "mips64el-linux")))))
 268
 269 (test-equal "output list"
 270   2
 271   (let ((exp (gexp (begin (mkdir (ungexp output))
 272                           (mkdir (ungexp output "bar"))))))
 273     (length (gexp-outputs exp))))                ;XXX: <output-ref> is private
 274
 275 (test-assert "output list, combined gexps"
 276   (let* ((exp0  (gexp (mkdir (ungexp output))))
 277          (exp1  (gexp (mkdir (ungexp output "foo"))))
 278          (exp2  (gexp (begin (display "hi!") (ungexp exp0) (ungexp exp1)))))
 279     (and (lset= equal?
 280                 (append (gexp-outputs exp0) (gexp-outputs exp1))
 281                 (gexp-outputs exp2))
 282          (= 2 (length (gexp-outputs exp2))))))
 283
 284 (test-equal "output list, combined gexps, duplicate output"
 285   1
 286   (let* ((exp0 (gexp (mkdir (ungexp output))))
 287          (exp1 (gexp (begin (mkdir (ungexp output)) (ungexp exp0))))
 288          (exp2 (gexp (begin (mkdir (ungexp output)) (ungexp exp1)))))
 289     (length (gexp-outputs exp2))))
 290
 291 (test-assert "output list + ungexp-splicing list, combined gexps"
 292   (let* ((exp0  (gexp (mkdir (ungexp output))))
 293          (exp1  (gexp (mkdir (ungexp output "foo"))))
 294          (exp2  (gexp (begin (display "hi!")
 295                              (ungexp-splicing (list exp0 exp1))))))
 296     (and (lset= equal?
 297                 (append (gexp-outputs exp0) (gexp-outputs exp1))
 298                 (gexp-outputs exp2))
 299          (= 2 (length (gexp-outputs exp2))))))
 300
 301 (test-assertm "gexp->file"
 302   (mlet* %store-monad ((exp -> (gexp (display (ungexp %bootstrap-guile))))
 303                        (guile  (package-file %bootstrap-guile))
 304                        (sexp   (gexp->sexp exp))
 305                        (drv    (gexp->file "foo" exp))
 306                        (out -> (derivation->output-path drv))
 307                        (done   (built-derivations (list drv)))
 308                        (refs   ((store-lift references) out)))
 309     (return (and (equal? sexp (call-with-input-file out read))
 310                  (equal? (list guile) refs)))))
 311
 312 (test-assertm "gexp->derivation"
 313   (mlet* %store-monad ((file    (text-file "foo" "Hello, world!"))
 314                        (exp ->  (gexp
 315                                  (begin
 316                                    (mkdir (ungexp output))
 317                                    (chdir (ungexp output))
 318                                    (symlink
 319                                     (string-append (ungexp %bootstrap-guile)
 320                                                    "/bin/guile")
 321                                     "foo")
 322                                    (symlink (ungexp file)
 323                                             (ungexp output "2nd")))))
 324                        (drv     (gexp->derivation "foo" exp))
 325                        (out ->  (derivation->output-path drv))
 326                        (out2 -> (derivation->output-path drv "2nd"))
 327                        (done    (built-derivations (list drv)))
 328                        (refs    ((store-lift references) out))
 329                        (refs2   ((store-lift references) out2))
 330                        (guile   (package-file %bootstrap-guile "bin/guile")))
 331     (return (and (string=? (readlink (string-append out "/foo")) guile)
 332                  (string=? (readlink out2) file)
 333                  (equal? refs (list (dirname (dirname guile))))
 334                  (equal? refs2 (list file))))))
 335
 336 (test-assertm "gexp->derivation vs. grafts"
 337   (mlet* %store-monad ((p0 ->   (dummy-package "dummy"
 338                                                (arguments
 339                                                 '(#:implicit-inputs? #f))))
 340                        (r  ->   (package (inherit p0) (name "DuMMY")))
 341                        (p1 ->   (package (inherit p0) (replacement r)))
 342                        (exp0 -> (gexp (frob (ungexp p0) (ungexp output))))
 343                        (exp1 -> (gexp (frob (ungexp p1) (ungexp output))))
 344                        (void    (set-guile-for-build %bootstrap-guile))
 345                        (drv0    (gexp->derivation "t" exp0))
 346                        (drv1    (gexp->derivation "t" exp1))
 347                        (drv1*   (gexp->derivation "t" exp1 #:graft? #f)))
 348     (return (and (not (string=? (derivation->output-path drv0)
 349                                 (derivation->output-path drv1)))
 350                  (string=? (derivation->output-path drv0)
 351                            (derivation->output-path drv1*))))))
 352
 353 (test-assertm "gexp->derivation, composed gexps"
 354   (mlet* %store-monad ((exp0 -> (gexp (begin
 355                                         (mkdir (ungexp output))
 356                                         (chdir (ungexp output)))))
 357                        (exp1 -> (gexp (symlink
 358                                        (string-append (ungexp %bootstrap-guile)
 359                                                       "/bin/guile")
 360                                        "foo")))
 361                        (exp  -> (gexp (begin (ungexp exp0) (ungexp exp1))))
 362                        (drv     (gexp->derivation "foo" exp))
 363                        (out ->  (derivation->output-path drv))
 364                        (done    (built-derivations (list drv)))
 365                        (guile   (package-file %bootstrap-guile "bin/guile")))
 366     (return (string=? (readlink (string-append out "/foo"))
 367                       guile))))
 368
 369 (test-assertm "gexp->derivation, default system"
 370   ;; The default system should be the one at '>>=' time, not the one at
 371   ;; invocation time.  See <http://bugs.gnu.org/18002>.
 372   (let ((system (%current-system))
 373         (mdrv   (parameterize ((%current-system "foobar64-linux"))
 374                   (gexp->derivation "foo"
 375                                     (gexp
 376                                      (mkdir (ungexp output)))))))
 377     (mlet %store-monad ((drv mdrv))
 378       (return (string=? system (derivation-system drv))))))
 379
 380 (test-assertm "gexp->derivation, local-file"
 381   (mlet* %store-monad ((file ->  (search-path %load-path "guix.scm"))
 382                        (intd     (interned-file file #:recursive? #f))
 383                        (local -> (local-file file))
 384                        (exp ->   (gexp (begin
 385                                          (stat (ungexp local))
 386                                          (symlink (ungexp local)
 387                                                   (ungexp output)))))
 388                        (drv      (gexp->derivation "local-file" exp)))
 389     (mbegin %store-monad
 390       (built-derivations (list drv))
 391       (return (string=? (readlink (derivation->output-path drv))
 392                         intd)))))
 393
 394 (test-assertm "gexp->derivation, cross-compilation"
 395   (mlet* %store-monad ((target -> "mips64el-linux")
 396                        (exp    -> (gexp (list (ungexp coreutils)
 397                                               (ungexp output))))
 398                        (xdrv      (gexp->derivation "foo" exp
 399                                                     #:target target))
 400                        (refs      ((store-lift references)
 401                                    (derivation-file-name xdrv)))
 402                        (xcu       (package->cross-derivation coreutils
 403                                                              target))
 404                        (cu        (package->derivation coreutils)))
 405     (return (and (member (derivation-file-name xcu) refs)
 406                  (not (member (derivation-file-name cu) refs))))))
 407
 408 (test-assertm "gexp->derivation, ungexp-native"
 409   (mlet* %store-monad ((target -> "mips64el-linux")
 410                        (exp    -> (gexp (list (ungexp-native coreutils)
 411                                               (ungexp output))))
 412                        (xdrv      (gexp->derivation "foo" exp
 413                                                     #:target target))
 414                        (drv       (gexp->derivation "foo" exp)))
 415     (return (string=? (derivation-file-name drv)
 416                       (derivation-file-name xdrv)))))
 417
 418 (test-assertm "gexp->derivation, ungexp + ungexp-native"
 419   (mlet* %store-monad ((target -> "mips64el-linux")
 420                        (exp    -> (gexp (list (ungexp-native coreutils)
 421                                               (ungexp glibc)
 422                                               (ungexp output))))
 423                        (xdrv      (gexp->derivation "foo" exp
 424                                                     #:target target))
 425                        (refs      ((store-lift references)
 426                                    (derivation-file-name xdrv)))
 427                        (xglibc    (package->cross-derivation glibc target))
 428                        (cu        (package->derivation coreutils)))
 429     (return (and (member (derivation-file-name cu) refs)
 430                  (member (derivation-file-name xglibc) refs)))))
 431
 432 (test-assertm "gexp->derivation, ungexp-native + composed gexps"
 433   (mlet* %store-monad ((target -> "mips64el-linux")
 434                        (exp0   -> (gexp (list 1 2
 435                                               (ungexp coreutils))))
 436                        (exp    -> (gexp (list 0 (ungexp-native exp0))))
 437                        (xdrv      (gexp->derivation "foo" exp
 438                                                     #:target target))
 439                        (drv       (gexp->derivation "foo" exp)))
 440     (return (string=? (derivation-file-name drv)
 441                       (derivation-file-name xdrv)))))
 442
 443 (test-assertm "gexp->derivation, store copy"
 444   (let ((build-one #~(call-with-output-file #$output
 445                        (lambda (port)
 446                          (display "This is the one." port))))
 447         (build-two (lambda (one)
 448                      #~(begin
 449                          (mkdir #$output)
 450                          (symlink #$one (string-append #$output "/one"))
 451                          (call-with-output-file (string-append #$output "/two")
 452                            (lambda (port)
 453                              (display "This is the second one." port))))))
 454         (build-drv #~(begin
 455                        (use-modules (guix build store-copy))
 456
 457                        (mkdir #$output)
 458                        (populate-store '("graph") #$output))))
 459     (mlet* %store-monad ((one (gexp->derivation "one" build-one))
 460                          (two (gexp->derivation "two" (build-two one)))
 461                          (drv (gexp->derivation "store-copy" build-drv
 462                                                 #:references-graphs
 463                                                 `(("graph" ,two))
 464                                                 #:modules
 465                                                 '((guix build store-copy)
 466                                                   (guix build utils))))
 467                          (ok? (built-derivations (list drv)))
 468                          (out -> (derivation->output-path drv)))
 469       (let ((one (derivation->output-path one))
 470             (two (derivation->output-path two)))
 471         (return (and ok?
 472                      (file-exists? (string-append out "/" one))
 473                      (file-exists? (string-append out "/" two))
 474                      (file-exists? (string-append out "/" two "/two"))
 475                      (string=? (readlink (string-append out "/" two "/one"))
 476                                one)))))))
 477
 478 (test-assertm "imported-files"
 479   (mlet* %store-monad
 480       ((files -> `(("x"     . ,(search-path %load-path "ice-9/q.scm"))
 481                    ("a/b/c" . ,(search-path %load-path
 482                                             "guix/derivations.scm"))
 483                    ("p/q"   . ,(search-path %load-path "guix.scm"))
 484                    ("p/z"   . ,(search-path %load-path "guix/store.scm"))))
 485        (drv (imported-files files)))
 486     (mbegin %store-monad
 487       (built-derivations (list drv))
 488       (let ((dir (derivation->output-path drv)))
 489         (return
 490          (every (match-lambda
 491                  ((path . source)
 492                   (equal? (call-with-input-file (string-append dir "/" path)
 493                             get-bytevector-all)
 494                           (call-with-input-file source
 495                             get-bytevector-all))))
 496                 files))))))
 497
 498 (test-assertm "gexp->derivation #:modules"
 499   (mlet* %store-monad
 500       ((build ->  #~(begin
 501                       (use-modules (guix build utils))
 502                       (mkdir-p (string-append #$output "/guile/guix/nix"))
 503                       #t))
 504        (drv       (gexp->derivation "test-with-modules" build
 505                                     #:modules '((guix build utils)))))
 506     (mbegin %store-monad
 507       (built-derivations (list drv))
 508       (let* ((p (derivation->output-path drv))
 509              (s (stat (string-append p "/guile/guix/nix"))))
 510         (return (eq? (stat:type s) 'directory))))))
 511
 512 (test-assertm "gexp->derivation #:references-graphs"
 513   (mlet* %store-monad
 514       ((one (text-file "one" (random-text)))
 515        (two (gexp->derivation "two"
 516                               #~(symlink #$one #$output:chbouib)))
 517        (drv (gexp->derivation "ref-graphs"
 518                               #~(begin
 519                                   (use-modules (guix build store-copy))
 520                                   (with-output-to-file #$output
 521                                     (lambda ()
 522                                       (write (call-with-input-file "guile"
 523                                                read-reference-graph))))
 524                                   (with-output-to-file #$output:one
 525                                     (lambda ()
 526                                       (write (call-with-input-file "one"
 527                                                read-reference-graph))))
 528                                   (with-output-to-file #$output:two
 529                                     (lambda ()
 530                                       (write (call-with-input-file "two"
 531                                                read-reference-graph)))))
 532                               #:references-graphs `(("one" ,one)
 533                                                     ("two" ,two "chbouib")
 534                                                     ("guile" ,%bootstrap-guile))
 535                               #:modules '((guix build store-copy)
 536                                           (guix build utils))))
 537        (ok? (built-derivations (list drv)))
 538        (guile-drv  (package->derivation %bootstrap-guile))
 539        (bash       (interned-file (search-bootstrap-binary "bash"
 540                                                            (%current-system))
 541                                   "bash" #:recursive? #t))
 542        (g-one   -> (derivation->output-path drv "one"))
 543        (g-two   -> (derivation->output-path drv "two"))
 544        (g-guile -> (derivation->output-path drv)))
 545     (return (and ok?
 546                  (equal? (call-with-input-file g-one read) (list one))
 547                  (lset= string=?
 548                         (call-with-input-file g-two read)
 549                         (list one (derivation->output-path two "chbouib")))
 550
 551                  ;; Note: %BOOTSTRAP-GUILE depends on the bootstrap Bash.
 552                  (lset= string=?
 553                         (call-with-input-file g-guile read)
 554                         (list (derivation->output-path guile-drv) bash))))))
 555
 556 (test-assertm "gexp->derivation #:allowed-references"
 557   (mlet %store-monad ((drv (gexp->derivation "allowed-refs"
 558                                              #~(begin
 559                                                  (mkdir #$output)
 560                                                  (chdir #$output)
 561                                                  (symlink #$output "self")
 562                                                  (symlink #$%bootstrap-guile
 563                                                           "guile"))
 564                                              #:allowed-references
 565                                              (list "out" %bootstrap-guile))))
 566     (built-derivations (list drv))))
 567
 568 (test-assertm "gexp->derivation #:allowed-references, specific output"
 569   (mlet* %store-monad ((in  (gexp->derivation "thing"
 570                                               #~(begin
 571                                                   (mkdir #$output:ok)
 572                                                   (mkdir #$output:not-ok))))
 573                        (drv (gexp->derivation "allowed-refs"
 574                                               #~(begin
 575                                                   (pk #$in:not-ok)
 576                                                   (mkdir #$output)
 577                                                   (chdir #$output)
 578                                                   (symlink #$output "self")
 579                                                   (symlink #$in:ok "ok"))
 580                                               #:allowed-references
 581                                               (list "out"
 582                                                     (gexp-input in "ok")))))
 583     (built-derivations (list drv))))
 584
 585 (test-assert "gexp->derivation #:allowed-references, disallowed"
 586   (let ((drv (run-with-store %store
 587                (gexp->derivation "allowed-refs"
 588                                  #~(begin
 589                                      (mkdir #$output)
 590                                      (chdir #$output)
 591                                      (symlink #$%bootstrap-guile "guile"))
 592                                  #:allowed-references '()))))
 593     (guard (c ((nix-protocol-error? c) #t))
 594       (build-derivations %store (list drv))
 595       #f)))
 596
 597 (define shebang
 598   (string-append "#!" (derivation->output-path (%guile-for-build))
 599                  "/bin/guile --no-auto-compile"))
 600
 601 ;; If we're going to hit the silly shebang limit (128 chars on Linux-based
 602 ;; systems), then skip the following test.
 603 (test-skip (if (> (string-length shebang) 127) 1 0))
 604
 605 (test-assertm "gexp->script"
 606   (mlet* %store-monad ((n ->   (random (expt 2 50)))
 607                        (exp -> (gexp
 608                                 (system*
 609                                  (string-append (ungexp %bootstrap-guile)
 610                                                 "/bin/guile")
 611                                  "-c" (object->string
 612                                        '(display (expt (ungexp n) 2))))))
 613                        (drv    (gexp->script "guile-thing" exp
 614                                              #:guile %bootstrap-guile))
 615                        (out -> (derivation->output-path drv))
 616                        (done   (built-derivations (list drv))))
 617     (let* ((pipe  (open-input-pipe out))
 618            (str   (get-string-all pipe)))
 619       (return (and (zero? (close-pipe pipe))
 620                    (= (expt n 2) (string->number str)))))))
 621
 622 (test-assert "text-file*"
 623   (let ((references (store-lift references)))
 624     (run-with-store %store
 625       (mlet* %store-monad
 626           ((drv  (package->derivation %bootstrap-guile))
 627            (guile -> (derivation->output-path drv))
 628            (file (text-file "bar" "This is bar."))
 629            (text (text-file* "foo"
 630                              %bootstrap-guile "/bin/guile "
 631                              (gexp-input %bootstrap-guile "out") "/bin/guile "
 632                              drv "/bin/guile "
 633                              file))
 634            (done (built-derivations (list text)))
 635            (out -> (derivation->output-path text))
 636            (refs (references out)))
 637         ;; Make sure we get the right references and the right content.
 638         (return (and (lset= string=? refs (list guile file))
 639                      (equal? (call-with-input-file out get-string-all)
 640                              (string-append guile "/bin/guile "
 641                                             guile "/bin/guile "
 642                                             guile "/bin/guile "
 643                                             file)))))
 644       #:guile-for-build (package-derivation %store %bootstrap-guile))))
 645
 646 (test-assert "gexp->derivation vs. %current-target-system"
 647   (let ((mval (gexp->derivation "foo"
 648                                 #~(begin
 649                                     (mkdir #$output)
 650                                     (foo #+gnu-make))
 651                                 #:target #f)))
 652     ;; The value of %CURRENT-TARGET-SYSTEM at bind-time should have no
 653     ;; influence.
 654     (parameterize ((%current-target-system "fooooo"))
 655       (derivation? (run-with-store %store mval)))))
 656
 657 (test-assertm "lower-object"
 658   (mlet %store-monad ((drv1 (lower-object %bootstrap-guile))
 659                       (drv2 (lower-object (package-source coreutils)))
 660                       (item (lower-object (plain-file "foo" "Hello!"))))
 661     (return (and (derivation? drv1) (derivation? drv2)
 662                  (store-path? item)))))
 663
 664 (test-assert "printer"
 665   (string-match "^#<gexp \\(string-append .*#<package coreutils.*\
 666  \"/bin/uname\"\\) [[:xdigit:]]+>$"
 667                 (with-output-to-string
 668                   (lambda ()
 669                     (write
 670                      (gexp (string-append (ungexp coreutils)
 671                                           "/bin/uname")))))))
 672
 673 (test-assert "printer vs. ungexp-splicing"
 674   (string-match "^#<gexp .* [[:xdigit:]]+>$"
 675                 (with-output-to-string
 676                   (lambda ()
 677                     ;; #~(begin #$@#~())
 678                     (write
 679                      (gexp (begin (ungexp-splicing (gexp ())))))))))
 680
 681 (test-equal "sugar"
 682   '(gexp (foo (ungexp bar) (ungexp baz "out")
 683               (ungexp (chbouib 42))
 684               (ungexp-splicing (list x y z))
 685               (ungexp-native foo) (ungexp-native foo "out")
 686               (ungexp-native (chbouib 42))
 687               (ungexp-native-splicing (list x y z))))
 688   '#~(foo #$bar #$baz:out #$(chbouib 42) #$@(list x y z)
 689           #+foo #+foo:out #+(chbouib 42) #+@(list x y z)))
 690
 691 (test-end "gexp")
 692
 693 \f
 694 (exit (= (test-runner-fail-count (test-runner-current)) 0))
 695
 696 ;; Local Variables:
 697 ;; eval: (put 'test-assertm 'scheme-indent-function 1)
 698 ;; End: