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