tests/gexp.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 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 build-system trivial)
  27   #:use-module (guix tests)
  28   #:use-module ((guix build utils) #:select (with-directory-excursion))
  29   #:use-module ((guix utils) #:select (call-with-temporary-directory))
  30   #:use-module (gnu packages)
  31   #:use-module (gnu packages base)
  32   #:use-module (gnu packages bootstrap)
  33   #:use-module ((guix diagnostics) #:select (guix-warning-port))
  34   #:use-module (srfi srfi-1)
  35   #:use-module (srfi srfi-34)
  36   #:use-module (srfi srfi-64)
  37   #:use-module (rnrs io ports)
  38   #:use-module (ice-9 match)
  39   #:use-module (ice-9 regex)
  40   #:use-module (ice-9 popen)
  41   #:use-module (ice-9 ftw))
  42
  43 ;; Test the (guix gexp) module.
  44
  45 (define %store
  46   (open-connection-for-tests))
  47
  48 ;; Globally disable grafts because they can trigger early builds.
  49 (%graft? #f)
  50
  51 ;; For white-box testing.
  52 (define (gexp-inputs x)
  53   ((@@ (guix gexp) gexp-inputs) x))
  54 (define (gexp-native-inputs x)
  55   ((@@ (guix gexp) gexp-native-inputs) x))
  56 (define (gexp-outputs x)
  57   ((@@ (guix gexp) gexp-outputs) x))
  58 (define (gexp->sexp . x)
  59   (apply (@@ (guix gexp) gexp->sexp) x))
  60
  61 (define* (gexp->sexp* exp #:optional target)
  62   (run-with-store %store (gexp->sexp exp
  63                                      #:target target)
  64                   #:guile-for-build (%guile-for-build)))
  65
  66 (define %extension-package
  67   ;; Example of a package to use when testing 'with-extensions'.
  68   (dummy-package "extension"
  69                  (build-system trivial-build-system)
  70                  (arguments
  71                   `(#:guile ,%bootstrap-guile
  72                     #:modules ((guix build utils))
  73                     #:builder
  74                     (begin
  75                       (use-modules (guix build utils))
  76                       (let* ((out (string-append (assoc-ref %outputs "out")
  77                                                  "/share/guile/site/"
  78                                                  (effective-version))))
  79                         (mkdir-p out)
  80                         (call-with-output-file (string-append out "/hg2g.scm")
  81                           (lambda (port)
  82                             (define defmod 'define-module) ;fool Geiser
  83                             (write `(,defmod (hg2g)
  84                                       #:export (the-answer))
  85                                    port)
  86                             (write '(define the-answer 42) port)))))))))
  87
  88 \f
  89 (test-begin "gexp")
  90
  91 (test-equal "no refs"
  92   '(display "hello!")
  93   (let ((exp (gexp (display "hello!"))))
  94     (and (gexp? exp)
  95          (null? (gexp-inputs exp))
  96          (gexp->sexp* exp))))
  97
  98 (test-equal "unquote"
  99   '(display `(foo ,(+ 2 3)))
 100   (let ((exp (gexp (display `(foo ,(+ 2 3))))))
 101     (and (gexp? exp)
 102          (null? (gexp-inputs exp))
 103          (gexp->sexp* exp))))
 104
 105 (test-assert "one input package"
 106   (let ((exp (gexp (display (ungexp coreutils)))))
 107     (and (gexp? exp)
 108          (match (gexp-inputs exp)
 109            (((p "out"))
 110             (eq? p coreutils)))
 111          (equal? `(display ,(derivation->output-path
 112                              (package-derivation %store coreutils)))
 113                  (gexp->sexp* exp)))))
 114
 115 (test-assert "one input package, dotted list"
 116   (let ((exp (gexp (coreutils . (ungexp coreutils)))))
 117     (and (gexp? exp)
 118          (match (gexp-inputs exp)
 119            (((p "out"))
 120             (eq? p coreutils)))
 121          (equal? `(coreutils . ,(derivation->output-path
 122                                  (package-derivation %store coreutils)))
 123                  (gexp->sexp* exp)))))
 124
 125 (test-assert "one input origin"
 126   (let ((exp (gexp (display (ungexp (package-source coreutils))))))
 127     (and (gexp? exp)
 128          (match (gexp-inputs exp)
 129            (((o "out"))
 130             (eq? o (package-source coreutils))))
 131          (equal? `(display ,(derivation->output-path
 132                              (package-source-derivation
 133                               %store (package-source coreutils))))
 134                  (gexp->sexp* exp)))))
 135
 136 (test-assert "one local file"
 137   (let* ((file  (search-path %load-path "guix.scm"))
 138          (local (local-file file))
 139          (exp   (gexp (display (ungexp local))))
 140          (intd  (add-to-store %store (basename file) #f
 141                               "sha256" file)))
 142     (and (gexp? exp)
 143          (match (gexp-inputs exp)
 144            (((x "out"))
 145             (eq? x local)))
 146          (equal? `(display ,intd) (gexp->sexp* exp)))))
 147
 148 (test-assert "one local file, symlink"
 149   (let ((file (search-path %load-path "guix.scm"))
 150         (link (tmpnam)))
 151     (dynamic-wind
 152       (const #t)
 153       (lambda ()
 154         (symlink (canonicalize-path file) link)
 155         (let* ((local (local-file link "my-file" #:recursive? #f))
 156                (exp   (gexp (display (ungexp local))))
 157                (intd  (add-to-store %store "my-file" #f
 158                                     "sha256" file)))
 159           (and (gexp? exp)
 160                (match (gexp-inputs exp)
 161                  (((x "out"))
 162                   (eq? x local)))
 163                (equal? `(display ,intd) (gexp->sexp* exp)))))
 164       (lambda ()
 165         (false-if-exception (delete-file link))))))
 166
 167 (test-equal "local-file, relative file name"
 168   (canonicalize-path (search-path %load-path "guix/base32.scm"))
 169   (let ((directory (dirname (search-path %load-path
 170                                          "guix/build-system/gnu.scm"))))
 171     (with-directory-excursion directory
 172         (let ((file (local-file "../guix/base32.scm")))
 173           (local-file-absolute-file-name file)))))
 174
 175 (test-equal "local-file, non-literal relative file name"
 176   (canonicalize-path (search-path %load-path "guix/base32.scm"))
 177   (let ((directory (dirname (search-path %load-path
 178                                          "guix/build-system/gnu.scm"))))
 179     (with-directory-excursion directory
 180       (let ((file (local-file (string-copy "../base32.scm"))))
 181         (local-file-absolute-file-name file)))))
 182
 183 (test-assertm "local-file, #:select?"
 184   (mlet* %store-monad ((select? -> (lambda (file stat)
 185                                      (member (basename file)
 186                                              '("guix.scm" "tests"
 187                                                "gexp.scm"))))
 188                        (file -> (local-file ".." "directory"
 189                                             #:recursive? #t
 190                                             #:select? select?))
 191                        (dir (lower-object file)))
 192     (return (and (store-path? dir)
 193                  (equal? (scandir dir)
 194                          '("." ".." "guix.scm" "tests"))
 195                  (equal? (scandir (string-append dir "/tests"))
 196                          '("." ".." "gexp.scm"))))))
 197
 198 (test-assert "one plain file"
 199   (let* ((file     (plain-file "hi" "Hello, world!"))
 200          (exp      (gexp (display (ungexp file))))
 201          (expected (add-text-to-store %store "hi" "Hello, world!")))
 202     (and (gexp? exp)
 203          (match (gexp-inputs exp)
 204            (((x "out"))
 205             (eq? x file)))
 206          (equal? `(display ,expected) (gexp->sexp* exp)))))
 207
 208 (test-assert "same input twice"
 209   (let ((exp (gexp (begin
 210                      (display (ungexp coreutils))
 211                      (display (ungexp coreutils))))))
 212     (and (gexp? exp)
 213          (match (gexp-inputs exp)
 214            (((p "out"))
 215             (eq? p coreutils)))
 216          (let ((e `(display ,(derivation->output-path
 217                               (package-derivation %store coreutils)))))
 218            (equal? `(begin ,e ,e) (gexp->sexp* exp))))))
 219
 220 (test-assert "two input packages, one derivation, one file"
 221   (let* ((drv (build-expression->derivation
 222                %store "foo" 'bar
 223                #:guile-for-build (package-derivation %store %bootstrap-guile)))
 224          (txt (add-text-to-store %store "foo" "Hello, world!"))
 225          (exp (gexp (begin
 226                       (display (ungexp coreutils))
 227                       (display (ungexp %bootstrap-guile))
 228                       (display (ungexp drv))
 229                       (display (ungexp txt))))))
 230     (define (match-input thing)
 231       (match-lambda
 232        ((drv-or-pkg _ ...)
 233         (eq? thing drv-or-pkg))))
 234
 235     (and (gexp? exp)
 236          (= 4 (length (gexp-inputs exp)))
 237          (every (lambda (input)
 238                   (find (match-input input) (gexp-inputs exp)))
 239                 (list drv coreutils %bootstrap-guile txt))
 240          (let ((e0 `(display ,(derivation->output-path
 241                                (package-derivation %store coreutils))))
 242                (e1 `(display ,(derivation->output-path
 243                                (package-derivation %store %bootstrap-guile))))
 244                (e2 `(display ,(derivation->output-path drv)))
 245                (e3 `(display ,txt)))
 246            (equal? `(begin ,e0 ,e1 ,e2 ,e3) (gexp->sexp* exp))))))
 247
 248 (test-assert "file-append"
 249   (let* ((drv (package-derivation %store %bootstrap-guile))
 250          (fa  (file-append %bootstrap-guile "/bin/guile"))
 251          (exp #~(here we go #$fa)))
 252     (and (match (gexp->sexp* exp)
 253            (('here 'we 'go (? string? result))
 254             (string=? result
 255                       (string-append (derivation->output-path drv)
 256                                      "/bin/guile"))))
 257          (match (gexp-inputs exp)
 258            (((thing "out"))
 259             (eq? thing fa))))))
 260
 261 (test-assert "file-append, output"
 262   (let* ((drv (package-derivation %store glibc))
 263          (fa  (file-append glibc "/lib" "/debug"))
 264          (exp #~(foo #$fa:debug)))
 265     (and (match (gexp->sexp* exp)
 266            (('foo (? string? result))
 267             (string=? result
 268                       (string-append (derivation->output-path drv "debug")
 269                                      "/lib/debug"))))
 270          (match (gexp-inputs exp)
 271            (((thing "debug"))
 272             (eq? thing fa))))))
 273
 274 (test-assert "file-append, nested"
 275   (let* ((drv   (package-derivation %store glibc))
 276          (dir   (file-append glibc "/bin"))
 277          (slash (file-append dir "/"))
 278          (file  (file-append slash "getent"))
 279          (exp   #~(foo #$file)))
 280     (and (match (gexp->sexp* exp)
 281            (('foo (? string? result))
 282             (string=? result
 283                       (string-append (derivation->output-path drv)
 284                                      "/bin/getent"))))
 285          (match (gexp-inputs exp)
 286            (((thing "out"))
 287             (eq? thing file))))))
 288
 289 (test-assert "file-append, raw store item"
 290   (let* ((obj   (plain-file "example.txt" "Hello!"))
 291          (a     (file-append obj "/a"))
 292          (b     (file-append a "/b"))
 293          (c     (file-append b "/c"))
 294          (exp   #~(list #$c))
 295          (item  (run-with-store %store (lower-object obj)))
 296          (lexp  (run-with-store %store (lower-gexp exp))))
 297     (and (equal? (lowered-gexp-sexp lexp)
 298                  `(list ,(string-append item "/a/b/c")))
 299          (equal? (lowered-gexp-sources lexp)
 300                  (list item))
 301          (null? (lowered-gexp-inputs lexp)))))
 302
 303 (test-assertm "with-parameters for %current-system"
 304   (mlet* %store-monad ((system -> (match (%current-system)
 305                                     ("aarch64-linux" "x86_64-linux")
 306                                     (_               "aarch64-linux")))
 307                        (drv    (package->derivation coreutils system))
 308                        (obj -> (with-parameters ((%current-system system))
 309                                  coreutils))
 310                        (result (lower-object obj)))
 311     (return (string=? (derivation-file-name drv)
 312                       (derivation-file-name result)))))
 313
 314 (test-assertm "with-parameters for %current-target-system"
 315   (mlet* %store-monad ((target -> "riscv64-linux-gnu")
 316                        (drv    (package->cross-derivation coreutils target))
 317                        (obj -> (with-parameters
 318                                    ((%current-target-system target))
 319                                  coreutils))
 320                        (result (lower-object obj)))
 321     (return (string=? (derivation-file-name drv)
 322                       (derivation-file-name result)))))
 323
 324 (test-assert "with-parameters + file-append"
 325   (let* ((system (match (%current-system)
 326                    ("aarch64-linux" "x86_64-linux")
 327                    (_               "aarch64-linux")))
 328          (drv    (package-derivation %store coreutils system))
 329          (param  (make-parameter 7))
 330          (exp    #~(here we go #$(with-parameters ((%current-system system)
 331                                                    (param 42))
 332                                    (if (= (param) 42)
 333                                        (file-append coreutils "/bin/touch")
 334                                        %bootstrap-guile)))))
 335     (match (gexp->sexp* exp)
 336       (('here 'we 'go (? string? result))
 337        (string=? result
 338                  (string-append (derivation->output-path drv)
 339                                 "/bin/touch"))))))
 340 (test-equal "let-system"
 341   (list `(begin ,(%current-system) #t) '(system-binding) '()
 342         'low '() '())
 343   (let* ((exp #~(begin
 344                   #$(let-system system system)
 345                   #t))
 346          (low (run-with-store %store (lower-gexp exp))))
 347     (list (lowered-gexp-sexp low)
 348           (match (gexp-inputs exp)
 349             (((($ (@@ (guix gexp) <system-binding>)) "out"))
 350              '(system-binding))
 351             (x x))
 352           (gexp-native-inputs exp)
 353           'low
 354           (lowered-gexp-inputs low)
 355           (lowered-gexp-sources low))))
 356
 357 (test-equal "let-system, target"
 358   (list `(list ,(%current-system) #f)
 359         `(list ,(%current-system) "aarch64-linux-gnu"))
 360   (let ((exp #~(list #$@(let-system (system target)
 361                           (list system target)))))
 362     (list (gexp->sexp* exp)
 363           (gexp->sexp* exp "aarch64-linux-gnu"))))
 364
 365 (test-equal "let-system, ungexp-native, target"
 366   `(here it is: ,(%current-system) #f)
 367   (let ((exp #~(here it is: #+@(let-system (system target)
 368                                  (list system target)))))
 369     (gexp->sexp* exp "aarch64-linux-gnu")))
 370
 371 (test-equal "let-system, nested"
 372   (list `(system* ,(string-append "qemu-system-" (%current-system))
 373                   "-m" "256")
 374         '()
 375         '(system-binding))
 376   (let ((exp #~(system*
 377                 #+(let-system (system target)
 378                     (file-append (@@ (gnu packages virtualization)
 379                                      qemu)
 380                                  "/bin/qemu-system-"
 381                                  system))
 382                 "-m" "256")))
 383     (list (match (gexp->sexp* exp)
 384             (('system* command rest ...)
 385              `(system* ,(and (string-prefix? (%store-prefix) command)
 386                              (basename command))
 387                        ,@rest))
 388             (x x))
 389           (gexp-inputs exp)
 390           (match (gexp-native-inputs exp)
 391             (((($ (@@ (guix gexp) <system-binding>)) "out"))
 392              '(system-binding))
 393             (x x)))))
 394
 395 (test-assert "ungexp + ungexp-native"
 396   (let* ((exp    (gexp (list (ungexp-native %bootstrap-guile)
 397                              (ungexp coreutils)
 398                              (ungexp-native glibc)
 399                              (ungexp binutils))))
 400          (target "mips64el-linux")
 401          (guile  (derivation->output-path
 402                   (package-derivation %store %bootstrap-guile)))
 403          (cu     (derivation->output-path
 404                   (package-cross-derivation %store coreutils target)))
 405          (libc   (derivation->output-path
 406                   (package-derivation %store glibc)))
 407          (bu     (derivation->output-path
 408                   (package-cross-derivation %store binutils target))))
 409     (and (lset= equal?
 410                 `((,%bootstrap-guile "out") (,glibc "out"))
 411                 (gexp-native-inputs exp))
 412          (lset= equal?
 413                 `((,coreutils "out") (,binutils "out"))
 414                 (gexp-inputs exp))
 415          (equal? `(list ,guile ,cu ,libc ,bu)
 416                  (gexp->sexp* exp target)))))
 417
 418 (test-equal "ungexp + ungexp-native, nested"
 419   (list `((,%bootstrap-guile "out")) '<> `((,coreutils "out")))
 420   (let* ((exp (gexp (list (ungexp-native (gexp (ungexp coreutils)))
 421                           (ungexp %bootstrap-guile)))))
 422     (list (gexp-inputs exp) '<> (gexp-native-inputs exp))))
 423
 424 (test-equal "ungexp + ungexp-native, nested, special mixture"
 425   `(() <> ((,coreutils "out")))
 426
 427   ;; (gexp-native-inputs exp) used to return '(), wrongfully.
 428   (let* ((foo (gexp (foo (ungexp-native coreutils))))
 429          (exp (gexp (bar (ungexp foo)))))
 430     (list (gexp-inputs exp) '<> (gexp-native-inputs exp))))
 431
 432 (test-assert "input list"
 433   (let ((exp   (gexp (display
 434                       '(ungexp (list %bootstrap-guile coreutils)))))
 435         (guile (derivation->output-path
 436                 (package-derivation %store %bootstrap-guile)))
 437         (cu    (derivation->output-path
 438                 (package-derivation %store coreutils))))
 439     (and (lset= equal?
 440                 `((,%bootstrap-guile "out") (,coreutils "out"))
 441                 (gexp-inputs exp))
 442          (equal? `(display '(,guile ,cu))
 443                  (gexp->sexp* exp)))))
 444
 445 (test-assert "input list + ungexp-native"
 446   (let* ((target "mips64el-linux")
 447          (exp   (gexp (display
 448                        (cons '(ungexp-native (list %bootstrap-guile coreutils))
 449                              '(ungexp (list glibc binutils))))))
 450          (guile (derivation->output-path
 451                  (package-derivation %store %bootstrap-guile)))
 452          (cu    (derivation->output-path
 453                  (package-derivation %store coreutils)))
 454          (xlibc (derivation->output-path
 455                  (package-cross-derivation %store glibc target)))
 456          (xbu   (derivation->output-path
 457                  (package-cross-derivation %store binutils target))))
 458     (and (lset= equal?
 459                 `((,%bootstrap-guile "out") (,coreutils "out"))
 460                 (gexp-native-inputs exp))
 461          (lset= equal?
 462                 `((,glibc "out") (,binutils "out"))
 463                 (gexp-inputs exp))
 464          (equal? `(display (cons '(,guile ,cu) '(,xlibc ,xbu)))
 465                  (gexp->sexp* exp target)))))
 466
 467 (test-assert "input list splicing"
 468   (let* ((inputs  (list (gexp-input glibc "debug") %bootstrap-guile))
 469          (outputs (list (derivation->output-path
 470                          (package-derivation %store glibc)
 471                          "debug")
 472                         (derivation->output-path
 473                          (package-derivation %store %bootstrap-guile))))
 474          (exp     (gexp (list (ungexp-splicing (cons (+ 2 3) inputs))))))
 475     (and (lset= equal?
 476                 `((,glibc "debug") (,%bootstrap-guile "out"))
 477                 (gexp-inputs exp))
 478          (equal? (gexp->sexp* exp)
 479                  `(list ,@(cons 5 outputs))))))
 480
 481 (test-assert "input list splicing + ungexp-native-splicing"
 482   (let* ((inputs (list (gexp-input glibc "debug" #:native? #t)
 483                        %bootstrap-guile))
 484          (exp    (gexp (list (ungexp-native-splicing (cons (+ 2 3) inputs))))))
 485     (and (lset= equal?
 486                 `((,glibc "debug") (,%bootstrap-guile "out"))
 487                 (gexp-native-inputs exp))
 488          (null? (gexp-inputs exp))
 489          (equal? (gexp->sexp* exp)                ;native
 490                  (gexp->sexp* exp "mips64el-linux")))))
 491
 492 (test-assert "gexp list splicing + ungexp-splicing"
 493   (let* ((inner (gexp (ungexp-native glibc)))
 494          (exp   (gexp (list (ungexp-splicing (list inner))))))
 495     (and (equal? `((,glibc "out")) (gexp-native-inputs exp))
 496          (null? (gexp-inputs exp))
 497          (equal? (gexp->sexp* exp)                ;native
 498                  (gexp->sexp* exp "mips64el-linux")))))
 499
 500 (test-equal "output list"
 501   2
 502   (let ((exp (gexp (begin (mkdir (ungexp output))
 503                           (mkdir (ungexp output "bar"))))))
 504     (length (gexp-outputs exp))))                ;XXX: <output-ref> is private
 505
 506 (test-assert "output list, combined gexps"
 507   (let* ((exp0  (gexp (mkdir (ungexp output))))
 508          (exp1  (gexp (mkdir (ungexp output "foo"))))
 509          (exp2  (gexp (begin (display "hi!") (ungexp exp0) (ungexp exp1)))))
 510     (and (lset= equal?
 511                 (append (gexp-outputs exp0) (gexp-outputs exp1))
 512                 (gexp-outputs exp2))
 513          (= 2 (length (gexp-outputs exp2))))))
 514
 515 (test-equal "output list, combined gexps, duplicate output"
 516   1
 517   (let* ((exp0 (gexp (mkdir (ungexp output))))
 518          (exp1 (gexp (begin (mkdir (ungexp output)) (ungexp exp0))))
 519          (exp2 (gexp (begin (mkdir (ungexp output)) (ungexp exp1)))))
 520     (length (gexp-outputs exp2))))
 521
 522 (test-assert "output list + ungexp-splicing list, combined gexps"
 523   (let* ((exp0  (gexp (mkdir (ungexp output))))
 524          (exp1  (gexp (mkdir (ungexp output "foo"))))
 525          (exp2  (gexp (begin (display "hi!")
 526                              (ungexp-splicing (list exp0 exp1))))))
 527     (and (lset= equal?
 528                 (append (gexp-outputs exp0) (gexp-outputs exp1))
 529                 (gexp-outputs exp2))
 530          (= 2 (length (gexp-outputs exp2))))))
 531
 532 (test-assertm "gexp->file"
 533   (mlet* %store-monad ((exp -> (gexp (display (ungexp %bootstrap-guile))))
 534                        (guile  (package-file %bootstrap-guile))
 535                        (sexp   (gexp->sexp exp))
 536                        (drv    (gexp->file "foo" exp))
 537                        (out -> (derivation->output-path drv))
 538                        (done   (built-derivations (list drv)))
 539                        (refs   (references* out)))
 540     (return (and (equal? sexp (call-with-input-file out read))
 541                  (equal? (list guile) refs)))))
 542
 543 (test-assertm "gexp->file + file-append"
 544   (mlet* %store-monad ((exp -> #~#$(file-append %bootstrap-guile
 545                                                 "/bin/guile"))
 546                        (guile  (package-file %bootstrap-guile))
 547                        (drv    (gexp->file "foo" exp))
 548                        (out -> (derivation->output-path drv))
 549                        (done   (built-derivations (list drv)))
 550                        (refs   (references* out)))
 551     (return (and (equal? (string-append guile "/bin/guile")
 552                          (call-with-input-file out read))
 553                  (equal? (list guile) refs)))))
 554
 555 (test-assertm "gexp->file + #:splice?"
 556   (mlet* %store-monad ((exp -> (list
 557                                 #~(define foo 'bar)
 558                                 #~(define guile #$%bootstrap-guile)))
 559                        (guile  (package-file %bootstrap-guile))
 560                        (drv    (gexp->file "splice" exp #:splice? #t))
 561                        (out -> (derivation->output-path drv))
 562                        (done   (built-derivations (list drv)))
 563                        (refs   (references* out)))
 564     (pk 'splice out)
 565     (return (and (equal? `((define foo 'bar)
 566                            (define guile ,guile)
 567                            ,(call-with-input-string "" read))
 568                          (call-with-input-file out
 569                            (lambda (port)
 570                              (list (read port) (read port) (read port)))))
 571                  (equal? (list guile) refs)))))
 572
 573 (test-assertm "gexp->derivation"
 574   (mlet* %store-monad ((file    (text-file "foo" "Hello, world!"))
 575                        (exp ->  (gexp
 576                                  (begin
 577                                    (mkdir (ungexp output))
 578                                    (chdir (ungexp output))
 579                                    (symlink
 580                                     (string-append (ungexp %bootstrap-guile)
 581                                                    "/bin/guile")
 582                                     "foo")
 583                                    (symlink (ungexp file)
 584                                             (ungexp output "2nd")))))
 585                        (drv     (gexp->derivation "foo" exp))
 586                        (out ->  (derivation->output-path drv))
 587                        (out2 -> (derivation->output-path drv "2nd"))
 588                        (done    (built-derivations (list drv)))
 589                        (refs    (references* out))
 590                        (refs2   (references* out2))
 591                        (guile   (package-file %bootstrap-guile "bin/guile")))
 592     (return (and (string=? (readlink (string-append out "/foo")) guile)
 593                  (string=? (readlink out2) file)
 594                  (equal? refs (list (dirname (dirname guile))))
 595                  (equal? refs2 (list file))
 596                  (null? (derivation-properties drv))))))
 597
 598 (test-assertm "gexp->derivation properties"
 599   (mlet %store-monad ((drv (gexp->derivation "foo"
 600                                              #~(mkdir #$output)
 601                                              #:properties '((type . test)))))
 602     (return (equal? '((type . test))
 603                     (derivation-properties drv)))))
 604
 605 (test-assertm "gexp->derivation vs. grafts"
 606   (mlet* %store-monad ((graft?  (set-grafting #f))
 607                        (p0 ->   (dummy-package "dummy"
 608                                                (arguments
 609                                                 '(#:implicit-inputs? #f))))
 610                        (r  ->   (package (inherit p0) (name "DuMMY")))
 611                        (p1 ->   (package (inherit p0) (replacement r)))
 612                        (exp0 -> (gexp (frob (ungexp p0) (ungexp output))))
 613                        (exp1 -> (gexp (frob (ungexp p1) (ungexp output))))
 614                        (void    (set-guile-for-build %bootstrap-guile))
 615                        (drv0    (gexp->derivation "t" exp0 #:graft? #t))
 616                        (drv1    (gexp->derivation "t" exp1 #:graft? #t))
 617                        (drv1*   (gexp->derivation "t" exp1 #:graft? #f))
 618                        (_       (set-grafting graft?)))
 619     (return (and (not (string=? (derivation->output-path drv0)
 620                                 (derivation->output-path drv1)))
 621                  (string=? (derivation->output-path drv0)
 622                            (derivation->output-path drv1*))))))
 623
 624 (test-assertm "gexp->derivation, composed gexps"
 625   (mlet* %store-monad ((exp0 -> (gexp (begin
 626                                         (mkdir (ungexp output))
 627                                         (chdir (ungexp output)))))
 628                        (exp1 -> (gexp (symlink
 629                                        (string-append (ungexp %bootstrap-guile)
 630                                                       "/bin/guile")
 631                                        "foo")))
 632                        (exp  -> (gexp (begin (ungexp exp0) (ungexp exp1))))
 633                        (drv     (gexp->derivation "foo" exp))
 634                        (out ->  (derivation->output-path drv))
 635                        (done    (built-derivations (list drv)))
 636                        (guile   (package-file %bootstrap-guile "bin/guile")))
 637     (return (string=? (readlink (string-append out "/foo"))
 638                       guile))))
 639
 640 (test-assertm "gexp->derivation, default system"
 641   ;; The default system should be the one at '>>=' time, not the one at
 642   ;; invocation time.  See <http://bugs.gnu.org/18002>.
 643   (let ((system (%current-system))
 644         (mdrv   (parameterize ((%current-system "foobar64-linux"))
 645                   (gexp->derivation "foo"
 646                                     (gexp
 647                                      (mkdir (ungexp output)))))))
 648     (mlet %store-monad ((drv mdrv))
 649       (return (string=? system (derivation-system drv))))))
 650
 651 (test-assertm "gexp->derivation, local-file"
 652   (mlet* %store-monad ((file ->  (search-path %load-path "guix.scm"))
 653                        (intd     (interned-file file #:recursive? #f))
 654                        (local -> (local-file file))
 655                        (exp ->   (gexp (begin
 656                                          (stat (ungexp local))
 657                                          (symlink (ungexp local)
 658                                                   (ungexp output)))))
 659                        (drv      (gexp->derivation "local-file" exp)))
 660     (mbegin %store-monad
 661       (built-derivations (list drv))
 662       (return (string=? (readlink (derivation->output-path drv))
 663                         intd)))))
 664
 665 (test-assertm "gexp->derivation, cross-compilation"
 666   (mlet* %store-monad ((target -> "mips64el-linux")
 667                        (exp    -> (gexp (list (ungexp coreutils)
 668                                               (ungexp output))))
 669                        (xdrv      (gexp->derivation "foo" exp
 670                                                     #:target target))
 671                        (refs      (references*
 672                                    (derivation-file-name xdrv)))
 673                        (xcu       (package->cross-derivation coreutils
 674                                                              target))
 675                        (cu        (package->derivation coreutils)))
 676     (return (and (member (derivation-file-name xcu) refs)
 677                  (not (member (derivation-file-name cu) refs))))))
 678
 679 (test-assertm "gexp->derivation, ungexp-native"
 680   (mlet* %store-monad ((target -> "mips64el-linux")
 681                        (exp    -> (gexp (list (ungexp-native coreutils)
 682                                               (ungexp output))))
 683                        (xdrv      (gexp->derivation "foo" exp
 684                                                     #:target target))
 685                        (drv       (gexp->derivation "foo" exp)))
 686     (return (string=? (derivation-file-name drv)
 687                       (derivation-file-name xdrv)))))
 688
 689 (test-assertm "gexp->derivation, ungexp + ungexp-native"
 690   (mlet* %store-monad ((target -> "mips64el-linux")
 691                        (exp    -> (gexp (list (ungexp-native coreutils)
 692                                               (ungexp glibc)
 693                                               (ungexp output))))
 694                        (xdrv      (gexp->derivation "foo" exp
 695                                                     #:target target))
 696                        (refs      (references*
 697                                    (derivation-file-name xdrv)))
 698                        (xglibc    (package->cross-derivation glibc target))
 699                        (cu        (package->derivation coreutils)))
 700     (return (and (member (derivation-file-name cu) refs)
 701                  (member (derivation-file-name xglibc) refs)))))
 702
 703 (test-assertm "gexp->derivation, ungexp-native + composed gexps"
 704   (mlet* %store-monad ((target -> "mips64el-linux")
 705                        (exp0   -> (gexp (list 1 2
 706                                               (ungexp coreutils))))
 707                        (exp    -> (gexp (list 0 (ungexp-native exp0))))
 708                        (xdrv      (gexp->derivation "foo" exp
 709                                                     #:target target))
 710                        (drv       (gexp->derivation "foo" exp)))
 711     (return (string=? (derivation-file-name drv)
 712                       (derivation-file-name xdrv)))))
 713
 714 (test-assertm "gexp->derivation, store copy"
 715   (let ((build-one #~(call-with-output-file #$output
 716                        (lambda (port)
 717                          (display "This is the one." port))))
 718         (build-two (lambda (one)
 719                      #~(begin
 720                          (mkdir #$output)
 721                          (symlink #$one (string-append #$output "/one"))
 722                          (call-with-output-file (string-append #$output "/two")
 723                            (lambda (port)
 724                              (display "This is the second one." port))))))
 725         (build-drv #~(begin
 726                        (use-modules (guix build store-copy))
 727
 728                        (mkdir #$output)
 729                        (populate-store '("graph") #$output))))
 730     (mlet* %store-monad ((one (gexp->derivation "one" build-one))
 731                          (two (gexp->derivation "two" (build-two one)))
 732                          (drv (gexp->derivation "store-copy" build-drv
 733                                                 #:references-graphs
 734                                                 `(("graph" ,two))
 735                                                 #:modules
 736                                                 '((guix build store-copy)
 737                                                   (guix progress)
 738                                                   (guix records)
 739                                                   (guix sets)
 740                                                   (guix build utils))))
 741                          (ok? (built-derivations (list drv)))
 742                          (out -> (derivation->output-path drv)))
 743       (let ((one (derivation->output-path one))
 744             (two (derivation->output-path two)))
 745         (return (and ok?
 746                      (file-exists? (string-append out "/" one))
 747                      (file-exists? (string-append out "/" two))
 748                      (file-exists? (string-append out "/" two "/two"))
 749                      (string=? (readlink (string-append out "/" two "/one"))
 750                                one)))))))
 751
 752 (test-assertm "imported-files"
 753   (mlet* %store-monad
 754       ((files -> `(("x"     . ,(search-path %load-path "ice-9/q.scm"))
 755                    ("a/b/c" . ,(search-path %load-path
 756                                             "guix/derivations.scm"))
 757                    ("p/q"   . ,(search-path %load-path "guix.scm"))
 758                    ("p/z"   . ,(search-path %load-path "guix/store.scm"))))
 759        (dir (imported-files files)))
 760     (mbegin %store-monad
 761       (return
 762        (every (match-lambda
 763                 ((path . source)
 764                  (equal? (call-with-input-file (string-append dir "/" path)
 765                            get-bytevector-all)
 766                          (call-with-input-file source
 767                            get-bytevector-all))))
 768               files)))))
 769
 770 (test-assertm "imported-files with file-like objects"
 771   (mlet* %store-monad ((plain -> (plain-file "foo" "bar!"))
 772                        (q-scm -> (search-path %load-path "ice-9/q.scm"))
 773                        (files -> `(("a/b/c" . ,q-scm)
 774                                    ("p/q"   . ,plain)))
 775                        (drv      (imported-files files)))
 776     (define (file=? file1 file2)
 777       ;; Assume deduplication is in place.
 778       (= (stat:ino (stat file1))
 779          (stat:ino (stat file2))))
 780
 781     (mbegin %store-monad
 782       (built-derivations (list (pk 'drv drv)))
 783       (mlet %store-monad ((dir -> (derivation->output-path drv))
 784                           (plain* (text-file "foo" "bar!"))
 785                           (q-scm* (interned-file q-scm "c")))
 786         (return
 787          (and (file=? (string-append dir "/a/b/c") q-scm*)
 788               (file=? (string-append dir "/p/q") plain*)))))))
 789
 790 (test-equal "gexp-modules & ungexp"
 791   '((bar) (foo))
 792   ((@@ (guix gexp) gexp-modules)
 793    #~(foo #$(with-imported-modules '((foo)) #~+)
 794           #+(with-imported-modules '((bar)) #~-))))
 795
 796 (test-equal "gexp-modules & ungexp-splicing"
 797   '((foo) (bar))
 798   ((@@ (guix gexp) gexp-modules)
 799    #~(foo #$@(list (with-imported-modules '((foo)) #~+)
 800                    (with-imported-modules '((bar)) #~-)))))
 801
 802 (test-assert "gexp-modules deletes duplicates"   ;<https://bugs.gnu.org/32966>
 803   (let ((make-file (lambda ()
 804                      ;; Use 'eval' to make sure we get an object that's not
 805                      ;; 'eq?' nor 'equal?' due to the closures it embeds.
 806                      (eval '(scheme-file "bar.scm" #~(define-module (bar)))
 807                            (current-module)))))
 808     (define result
 809       ((@@ (guix gexp) gexp-modules)
 810        (with-imported-modules `(((bar) => ,(make-file))
 811                                 ((bar) => ,(make-file))
 812                                 (foo) (foo))
 813          #~+)))
 814
 815     (match result
 816       (((('bar) '=> (? scheme-file?)) ('foo)) #t))))
 817
 818 (test-equal "gexp-modules and literal Scheme object"
 819   '()
 820   (gexp-modules #t))
 821
 822 (test-assert "gexp-modules, warning"
 823   (string-match "tests/gexp.scm:[0-9]+:[0-9]+: warning: \
 824 importing.* \\(guix config\\) from the host"
 825                 (call-with-output-string
 826                   (lambda (port)
 827                     (parameterize ((guix-warning-port port))
 828                       (let* ((x (with-imported-modules '((guix config))
 829                                   #~(+ 1 2 3)))
 830                              (y #~(+ 39 #$x)))
 831                         (gexp-modules y)))))))
 832
 833 (test-assertm "gexp->derivation #:modules"
 834   (mlet* %store-monad
 835       ((build ->  #~(begin
 836                       (use-modules (guix build utils))
 837                       (mkdir-p (string-append #$output "/guile/guix/nix"))
 838                       #t))
 839        (drv       (gexp->derivation "test-with-modules" build
 840                                     #:modules '((guix build utils)))))
 841     (mbegin %store-monad
 842       (built-derivations (list drv))
 843       (let* ((p (derivation->output-path drv))
 844              (s (stat (string-append p "/guile/guix/nix"))))
 845         (return (eq? (stat:type s) 'directory))))))
 846
 847 (test-assertm "gexp->derivation & with-imported-modules"
 848   ;; Same test as above, but using 'with-imported-modules'.
 849   (mlet* %store-monad
 850       ((build ->  (with-imported-modules '((guix build utils))
 851                     #~(begin
 852                         (use-modules (guix build utils))
 853                         (mkdir-p (string-append #$output "/guile/guix/nix"))
 854                         #t)))
 855        (drv       (gexp->derivation "test-with-modules" build)))
 856     (mbegin %store-monad
 857       (built-derivations (list drv))
 858       (let* ((p (derivation->output-path drv))
 859              (s (stat (string-append p "/guile/guix/nix"))))
 860         (return (eq? (stat:type s) 'directory))))))
 861
 862 (test-assertm "gexp->derivation & nested with-imported-modules"
 863   (mlet* %store-monad
 864       ((build1 ->  (with-imported-modules '((guix build utils))
 865                      #~(begin
 866                          (use-modules (guix build utils))
 867                          (mkdir-p (string-append #$output "/guile/guix/nix"))
 868                          #t)))
 869        (build2 ->  (with-imported-modules '((guix build bournish))
 870                      #~(begin
 871                          (use-modules (guix build bournish)
 872                                       (system base compile))
 873                          #+build1
 874                          (call-with-output-file (string-append #$output "/b")
 875                            (lambda (port)
 876                              (write
 877                               (read-and-compile (open-input-string "cd /foo")
 878                                                 #:from %bournish-language
 879                                                 #:to 'scheme)
 880                               port))))))
 881        (drv        (gexp->derivation "test-with-modules" build2)))
 882     (mbegin %store-monad
 883       (built-derivations (list drv))
 884       (let* ((p (derivation->output-path drv))
 885              (s (stat (string-append p "/guile/guix/nix")))
 886              (b (string-append p "/b")))
 887         (return (and (eq? (stat:type s) 'directory)
 888                      (equal? '(chdir "/foo")
 889                              (call-with-input-file b read))))))))
 890
 891 (test-assertm "gexp->derivation & with-imported-module & computed module"
 892   (mlet* %store-monad
 893       ((module -> (scheme-file "x" #~(;; splice!
 894                                        (define-module (foo bar)
 895                                          #:export (the-answer))
 896
 897                                        (define the-answer 42))
 898                                #:splice? #t))
 899        (build -> (with-imported-modules `(((foo bar) => ,module)
 900                                           (guix build utils))
 901                    #~(begin
 902                        (use-modules (guix build utils)
 903                                     (foo bar))
 904                        mkdir-p
 905                        (call-with-output-file #$output
 906                          (lambda (port)
 907                            (write the-answer port))))))
 908        (drv      (gexp->derivation "thing" build))
 909        (out ->   (derivation->output-path drv)))
 910     (mbegin %store-monad
 911       (built-derivations (list drv))
 912       (return (= 42 (call-with-input-file out read))))))
 913
 914 (test-equal "gexp-extensions & ungexp"
 915   (list sed grep)
 916   ((@@ (guix gexp) gexp-extensions)
 917    #~(foo #$(with-extensions (list grep) #~+)
 918           #+(with-extensions (list sed)  #~-))))
 919
 920 (test-equal "gexp-extensions & ungexp-splicing"
 921   (list grep sed)
 922   ((@@ (guix gexp) gexp-extensions)
 923    #~(foo #$@(list (with-extensions (list grep) #~+)
 924                    (with-imported-modules '((foo))
 925                      (with-extensions (list sed) #~-))))))
 926
 927 (test-equal "gexp-extensions and literal Scheme object"
 928   '()
 929   ((@@ (guix gexp) gexp-extensions) #t))
 930
 931 (test-assertm "gexp->derivation & with-extensions"
 932   ;; Create a fake Guile extension and make sure it is accessible both to the
 933   ;; imported modules and to the derivation build script.
 934   (mlet* %store-monad
 935       ((extension -> %extension-package)
 936        (module -> (scheme-file "x" #~( ;; splice!
 937                                       (define-module (foo)
 938                                         #:use-module (hg2g)
 939                                         #:export (multiply))
 940
 941                                       (define (multiply x)
 942                                         (* the-answer x)))
 943                                #:splice? #t))
 944        (build -> (with-extensions (list extension)
 945                    (with-imported-modules `((guix build utils)
 946                                             ((foo) => ,module))
 947                      #~(begin
 948                          (use-modules (guix build utils)
 949                                       (hg2g) (foo))
 950                          (call-with-output-file #$output
 951                            (lambda (port)
 952                              (write (list the-answer (multiply 2))
 953                                     port)))))))
 954        (drv      (gexp->derivation "thingie" build
 955                                    ;; %BOOTSTRAP-GUILE is 2.0.
 956                                    #:effective-version "2.0"))
 957        (out ->   (derivation->output-path drv)))
 958     (mbegin %store-monad
 959       (built-derivations (list drv))
 960       (return (equal? '(42 84) (call-with-input-file out read))))))
 961
 962 (test-assertm "lower-gexp"
 963   (mlet* %store-monad
 964       ((extension -> %extension-package)
 965        (extension-drv (package->derivation %extension-package))
 966        (coreutils-drv (package->derivation coreutils))
 967        (exp ->   (with-extensions (list extension)
 968                    (with-imported-modules `((guix build utils))
 969                      #~(begin
 970                          (use-modules (guix build utils)
 971                                       (hg2g))
 972                          #$coreutils:debug
 973                          mkdir-p
 974                          the-answer))))
 975        (lexp     (lower-gexp exp
 976                              #:effective-version "2.0")))
 977     (define (matching-input drv output)
 978       (lambda (input)
 979         (and (eq? (derivation-input-derivation input) drv)
 980              (equal? (derivation-input-sub-derivations input)
 981                      (list output)))))
 982
 983     (mbegin %store-monad
 984       (return (and (find (matching-input extension-drv "out")
 985                          (lowered-gexp-inputs (pk 'lexp lexp)))
 986                    (find (matching-input coreutils-drv "debug")
 987                          (lowered-gexp-inputs lexp))
 988                    (member (string-append
 989                             (derivation->output-path extension-drv)
 990                             "/share/guile/site/2.0")
 991                            (lowered-gexp-load-path lexp))
 992                    (= 2 (length (lowered-gexp-load-path lexp)))
 993                    (member (string-append
 994                             (derivation->output-path extension-drv)
 995                             "/lib/guile/2.0/site-ccache")
 996                            (lowered-gexp-load-compiled-path lexp))
 997                    (= 2 (length (lowered-gexp-load-compiled-path lexp)))
 998                    (eq? (derivation-input-derivation (lowered-gexp-guile lexp))
 999                         (%guile-for-build)))))))
1000
1001 (test-assertm "lower-gexp, raw-derivation-file"
1002   (mlet* %store-monad ((thing -> (program-file "prog" #~(display "hi!")))
1003                        (exp -> #~(list #$(raw-derivation-file thing)))
1004                        (drv  (lower-object thing))
1005                        (lexp (lower-gexp exp #:effective-version "2.0")))
1006     (return (and (equal? `(list ,(derivation-file-name drv))
1007                          (lowered-gexp-sexp lexp))
1008                  (equal? (list (derivation-file-name drv))
1009                          (lowered-gexp-sources lexp))
1010                  (null? (lowered-gexp-inputs lexp))))))
1011
1012 (test-eq "lower-gexp, non-self-quoting input"
1013   +
1014   (guard (c ((gexp-input-error? c)
1015              (gexp-error-invalid-input c)))
1016     (run-with-store %store
1017       (lower-gexp #~(foo #$+)))))
1018
1019 (test-equal "lower-gexp, character literal"
1020   '(#\+)
1021   (lowered-gexp-sexp
1022    (run-with-store %store
1023      (lower-gexp #~(#\+)))))
1024
1025 (test-assertm "gexp->derivation #:references-graphs"
1026   (mlet* %store-monad
1027       ((one (text-file "one" (random-text)))
1028        (two (gexp->derivation "two"
1029                               #~(symlink #$one #$output:chbouib)))
1030        (build -> (with-imported-modules '((guix build store-copy)
1031                                           (guix progress)
1032                                           (guix records)
1033                                           (guix sets)
1034                                           (guix build utils))
1035                    #~(begin
1036                        (use-modules (guix build store-copy))
1037                        (with-output-to-file #$output
1038                          (lambda ()
1039                            (write (map store-info-item
1040                                        (call-with-input-file "guile"
1041                                          read-reference-graph)))))
1042                        (with-output-to-file #$output:one
1043                          (lambda ()
1044                            (write (map store-info-item
1045                                        (call-with-input-file "one"
1046                                          read-reference-graph)))))
1047                        (with-output-to-file #$output:two
1048                          (lambda ()
1049                            (write (map store-info-item
1050                                        (call-with-input-file "two"
1051                                          read-reference-graph))))))))
1052        (drv (gexp->derivation "ref-graphs" build
1053                               #:references-graphs `(("one" ,one)
1054                                                     ("two" ,two "chbouib")
1055                                                     ("guile" ,%bootstrap-guile))))
1056        (ok? (built-derivations (list drv)))
1057        (guile-drv  (package->derivation %bootstrap-guile))
1058        (bash       (interned-file (search-bootstrap-binary "bash"
1059                                                            (%current-system))
1060                                   "bash" #:recursive? #t))
1061        (g-one   -> (derivation->output-path drv "one"))
1062        (g-two   -> (derivation->output-path drv "two"))
1063        (g-guile -> (derivation->output-path drv)))
1064     (return (and ok?
1065                  (equal? (call-with-input-file g-one read) (list one))
1066                  (lset= string=?
1067                         (call-with-input-file g-two read)
1068                         (list one (derivation->output-path two "chbouib")))
1069
1070                  ;; Note: %BOOTSTRAP-GUILE depends on the bootstrap Bash.
1071                  (lset= string=?
1072                         (call-with-input-file g-guile read)
1073                         (list (derivation->output-path guile-drv) bash))))))
1074
1075 (test-assertm "gexp->derivation #:allowed-references"
1076   (mlet %store-monad ((drv (gexp->derivation "allowed-refs"
1077                                              #~(begin
1078                                                  (mkdir #$output)
1079                                                  (chdir #$output)
1080                                                  (symlink #$output "self")
1081                                                  (symlink #$%bootstrap-guile
1082                                                           "guile"))
1083                                              #:allowed-references
1084                                              (list "out" %bootstrap-guile))))
1085     (built-derivations (list drv))))
1086
1087 (test-assertm "gexp->derivation #:allowed-references, specific output"
1088   (mlet* %store-monad ((in  (gexp->derivation "thing"
1089                                               #~(begin
1090                                                   (mkdir #$output:ok)
1091                                                   (mkdir #$output:not-ok))))
1092                        (drv (gexp->derivation "allowed-refs"
1093                                               #~(begin
1094                                                   (pk #$in:not-ok)
1095                                                   (mkdir #$output)
1096                                                   (chdir #$output)
1097                                                   (symlink #$output "self")
1098                                                   (symlink #$in:ok "ok"))
1099                                               #:allowed-references
1100                                               (list "out"
1101                                                     (gexp-input in "ok")))))
1102     (built-derivations (list drv))))
1103
1104 (test-assert "gexp->derivation #:allowed-references, disallowed"
1105   (let ((drv (run-with-store %store
1106                (gexp->derivation "allowed-refs"
1107                                  #~(begin
1108                                      (mkdir #$output)
1109                                      (chdir #$output)
1110                                      (symlink #$%bootstrap-guile "guile"))
1111                                  #:allowed-references '()))))
1112     (guard (c ((store-protocol-error? c) #t))
1113       (build-derivations %store (list drv))
1114       #f)))
1115
1116 (test-assertm "gexp->derivation #:disallowed-references, allowed"
1117   (mlet %store-monad ((drv (gexp->derivation "disallowed-refs"
1118                                              #~(begin
1119                                                  (mkdir #$output)
1120                                                  (chdir #$output)
1121                                                  (symlink #$output "self")
1122                                                  (symlink #$%bootstrap-guile
1123                                                           "guile"))
1124                                              #:disallowed-references '())))
1125     (built-derivations (list drv))))
1126
1127
1128 (test-assert "gexp->derivation #:disallowed-references"
1129   (let ((drv (run-with-store %store
1130                (gexp->derivation "disallowed-refs"
1131                                  #~(begin
1132                                      (mkdir #$output)
1133                                      (chdir #$output)
1134                                      (symlink #$%bootstrap-guile "guile"))
1135                                  #:disallowed-references (list %bootstrap-guile)))))
1136     (guard (c ((store-protocol-error? c) #t))
1137       (build-derivations %store (list drv))
1138       #f)))
1139
1140 (define shebang
1141   (string-append "#!" (derivation->output-path (%guile-for-build))
1142                  "/bin/guile --no-auto-compile"))
1143
1144 ;; If we're going to hit the silly shebang limit (128 chars on Linux-based
1145 ;; systems), then skip the following test.
1146 (test-skip (if (> (string-length shebang) 127) 2 0))
1147
1148 (test-assertm "gexp->script"
1149   (mlet* %store-monad ((n ->   (random (expt 2 50)))
1150                        (exp -> (gexp
1151                                 (system*
1152                                  (string-append (ungexp %bootstrap-guile)
1153                                                 "/bin/guile")
1154                                  "-c" (object->string
1155                                        '(display (expt (ungexp n) 2))))))
1156                        (drv    (gexp->script "guile-thing" exp
1157                                              #:guile %bootstrap-guile))
1158                        (out -> (derivation->output-path drv))
1159                        (done   (built-derivations (list drv))))
1160     (let* ((pipe  (open-input-pipe out))
1161            (str   (get-string-all pipe)))
1162       (return (and (zero? (close-pipe pipe))
1163                    (= (expt n 2) (string->number str)))))))
1164
1165 (test-assert "gexp->script #:module-path"
1166   (call-with-temporary-directory
1167    (lambda (directory)
1168      (define str
1169        "Fake (guix base32) module!")
1170
1171      (mkdir (string-append directory "/guix"))
1172      (call-with-output-file (string-append directory "/guix/base32.scm")
1173        (lambda (port)
1174          (write `(begin (define-module (guix base32))
1175                         (define-public %fake! ,str))
1176                 port)))
1177
1178      (run-with-store %store
1179        (mlet* %store-monad ((exp -> (with-imported-modules '((guix base32))
1180                                       (gexp (begin
1181                                               (use-modules (guix base32))
1182                                               (write (list %load-path
1183                                                            %fake!))))))
1184                             (drv    (gexp->script "guile-thing" exp
1185                                                   #:guile %bootstrap-guile
1186                                                   #:module-path (list directory)))
1187                             (out -> (derivation->output-path drv))
1188                             (done   (built-derivations (list drv))))
1189          (let* ((pipe  (open-input-pipe out))
1190                 (data  (read pipe)))
1191            (return (and (zero? (close-pipe pipe))
1192                         (match data
1193                           ((load-path str*)
1194                            (and (string=? str* str)
1195                                 (not (member directory load-path)))))))))))))
1196
1197 (test-assertm "program-file"
1198   (let* ((n      (random (expt 2 50)))
1199          (exp    (with-imported-modules '((guix build utils))
1200                    (gexp (begin
1201                            (use-modules (guix build utils))
1202                            (display (ungexp n))))))
1203          (file   (program-file "program" exp
1204                                #:guile %bootstrap-guile)))
1205     (mlet* %store-monad ((drv (lower-object file))
1206                          (out -> (derivation->output-path drv)))
1207       (mbegin %store-monad
1208         (built-derivations (list drv))
1209         (let* ((pipe  (open-input-pipe out))
1210                (str   (get-string-all pipe)))
1211           (return (and (zero? (close-pipe pipe))
1212                        (= n (string->number str)))))))))
1213
1214 (test-assert "program-file #:module-path"
1215   (call-with-temporary-directory
1216    (lambda (directory)
1217      (define text (random-text))
1218
1219      (call-with-output-file (string-append directory "/stupid-module.scm")
1220        (lambda (port)
1221          (write `(begin (define-module (stupid-module))
1222                         (define-public %stupid-thing ,text))
1223                 port)))
1224
1225      (let* ((exp    (with-imported-modules '((stupid-module))
1226                       (gexp (begin
1227                               (use-modules (stupid-module))
1228                               (display %stupid-thing)))))
1229             (file   (program-file "program" exp
1230                                   #:guile %bootstrap-guile
1231                                   #:module-path (list directory))))
1232        (run-with-store %store
1233          (mlet* %store-monad ((drv (lower-object file))
1234                               (out -> (derivation->output-path drv)))
1235            (mbegin %store-monad
1236              (built-derivations (list drv))
1237              (let* ((pipe  (open-input-pipe out))
1238                     (str   (get-string-all pipe)))
1239                (return (and (zero? (close-pipe pipe))
1240                             (string=? text str)))))))))))
1241
1242 (test-assertm "program-file & with-extensions"
1243   (let* ((exp    (with-extensions (list %extension-package)
1244                    (gexp (begin
1245                            (use-modules (hg2g))
1246                            (display the-answer)))))
1247          (file   (program-file "program" exp
1248                                #:guile %bootstrap-guile)))
1249     (mlet* %store-monad ((drv (lower-object file))
1250                          (out -> (derivation->output-path drv)))
1251       (mbegin %store-monad
1252         (built-derivations (list drv))
1253         (let* ((pipe  (open-input-pipe out))
1254                (str   (get-string-all pipe)))
1255           (return (and (zero? (close-pipe pipe))
1256                        (= 42 (string->number str)))))))))
1257
1258 (test-assertm "program-file #:system"
1259   (let* ((exp    (with-imported-modules '((guix build utils))
1260                    (gexp (begin
1261                            (use-modules (guix build utils))
1262                            (display "hi!")))))
1263          (system (if (string=? (%current-system) "x86_64-linux")
1264                      "armhf-linux"
1265                      "x86_64-linux"))
1266          (file   (program-file "program" exp)))
1267     (mlet %store-monad ((drv (lower-object file system)))
1268       (return (and (string=? (derivation-system drv) system)
1269                    (find (lambda (input)
1270                            (let ((drv (pk (derivation-input-derivation input))))
1271                              (and (string=? (derivation-name drv)
1272                                             "module-import-compiled")
1273                                   (string=? (derivation-system drv)
1274                                             system))))
1275                          (derivation-inputs drv)))))))
1276
1277 (test-assertm "scheme-file"
1278   (let* ((text   (plain-file "foo" "Hello, world!"))
1279          (scheme (scheme-file "bar" #~(list "foo" #$text))))
1280     (mlet* %store-monad ((drv  (lower-object scheme))
1281                          (text (lower-object text))
1282                          (out -> (derivation->output-path drv)))
1283       (mbegin %store-monad
1284         (built-derivations (list drv))
1285         (mlet %store-monad ((refs (references* out)))
1286           (return (and (equal? refs (list text))
1287                        (equal? `(list "foo" ,text)
1288                                (call-with-input-file out read)))))))))
1289
1290 (test-assertm "raw-derivation-file"
1291   (let* ((exp #~(let ((drv #$(raw-derivation-file coreutils)))
1292                   (when (file-exists? drv)
1293                     (symlink drv #$output)))))
1294     (mlet* %store-monad ((dep    (lower-object coreutils))
1295                          (drv    (gexp->derivation "drv-ref" exp))
1296                          (out -> (derivation->output-path drv)))
1297       (mbegin %store-monad
1298         (built-derivations (list drv))
1299         (mlet %store-monad ((refs (references* out)))
1300           (return (and (member (derivation-file-name dep)
1301                                (derivation-sources drv))
1302                        (not (member (derivation-file-name dep)
1303                                     (map derivation-input-path
1304                                          (derivation-inputs drv))))
1305                        (equal? (readlink out) (derivation-file-name dep))
1306                        (equal? refs (list (derivation-file-name dep))))))))))
1307
1308 (test-assert "text-file*"
1309   (run-with-store %store
1310     (mlet* %store-monad
1311         ((drv  (package->derivation %bootstrap-guile))
1312          (guile -> (derivation->output-path drv))
1313          (file (text-file "bar" "This is bar."))
1314          (text (text-file* "foo"
1315                            %bootstrap-guile "/bin/guile "
1316                            (gexp-input %bootstrap-guile "out") "/bin/guile "
1317                            drv "/bin/guile "
1318                            file))
1319          (done (built-derivations (list text)))
1320          (out -> (derivation->output-path text))
1321          (refs (references* out)))
1322       ;; Make sure we get the right references and the right content.
1323       (return (and (lset= string=? refs (list guile file))
1324                    (equal? (call-with-input-file out get-string-all)
1325                            (string-append guile "/bin/guile "
1326                                           guile "/bin/guile "
1327                                           guile "/bin/guile "
1328                                           file)))))
1329     #:guile-for-build (package-derivation %store %bootstrap-guile)))
1330
1331 (test-assertm "mixed-text-file"
1332   (mlet* %store-monad ((file ->   (mixed-text-file "mixed"
1333                                                    "export PATH="
1334                                                    %bootstrap-guile "/bin"))
1335                        (drv       (lower-object file))
1336                        (out ->    (derivation->output-path drv))
1337                        (guile-drv (package->derivation %bootstrap-guile))
1338                        (guile ->  (derivation->output-path guile-drv)))
1339     (mbegin %store-monad
1340       (built-derivations (list drv))
1341       (mlet %store-monad ((refs (references* out)))
1342         (return (and (string=? (string-append "export PATH=" guile "/bin")
1343                                (call-with-input-file out get-string-all))
1344                      (equal? refs (list guile))))))))
1345
1346 (test-assertm "file-union"
1347   (mlet* %store-monad ((union -> (file-union "union"
1348                                              `(("a" ,(plain-file "a" "1"))
1349                                                ("b/c/d" ,(plain-file "d" "2"))
1350                                                ("e" ,(plain-file "e" "3")))))
1351                        (drv      (lower-object union))
1352                        (out ->   (derivation->output-path drv)))
1353     (define (contents=? file str)
1354       (string=? (call-with-input-file (string-append out "/" file)
1355                   get-string-all)
1356                 str))
1357
1358     (mbegin %store-monad
1359       (built-derivations (list drv))
1360       (return (and (contents=? "a" "1")
1361                    (contents=? "b/c/d" "2")
1362                    (contents=? "e" "3"))))))
1363
1364 (test-assert "gexp->derivation vs. %current-target-system"
1365   (let ((mval (gexp->derivation "foo"
1366                                 #~(begin
1367                                     (mkdir #$output)
1368                                     (foo #+gnu-make))
1369                                 #:target #f)))
1370     ;; The value of %CURRENT-TARGET-SYSTEM at bind-time should have no
1371     ;; influence.
1372     (parameterize ((%current-target-system "fooooo"))
1373       (derivation? (run-with-store %store mval)))))
1374
1375 (test-assertm "lower-object"
1376   (mlet %store-monad ((drv1 (lower-object %bootstrap-guile))
1377                       (drv2 (lower-object (package-source coreutils)))
1378                       (item (lower-object (plain-file "foo" "Hello!"))))
1379     (return (and (derivation? drv1) (derivation? drv2)
1380                  (store-path? item)))))
1381
1382 (test-assertm "lower-object, computed-file"
1383   (let* ((text     (plain-file "foo" "Hello!"))
1384          (exp      #~(begin
1385                        (mkdir #$output)
1386                        (symlink #$%bootstrap-guile
1387                                 (string-append #$output "/guile"))
1388                        (symlink #$text (string-append #$output "/text"))))
1389          (computed (computed-file "computed" exp)))
1390     (mlet* %store-monad ((text      (lower-object text))
1391                          (guile-drv (lower-object %bootstrap-guile))
1392                          (comp-drv  (lower-object computed))
1393                          (comp ->   (derivation->output-path comp-drv)))
1394       (mbegin %store-monad
1395         (built-derivations (list comp-drv))
1396         (return (and (string=? (readlink (string-append comp "/guile"))
1397                                (derivation->output-path guile-drv))
1398                      (string=? (readlink (string-append comp "/text"))
1399                                text)))))))
1400
1401 (test-equal "lower-object, computed-file, #:system"
1402   '("mips64el-linux")
1403   (run-with-store %store
1404     (let* ((exp      #~(symlink #$coreutils #$output))
1405            (computed (computed-file "computed" exp
1406                                     #:guile %bootstrap-guile)))
1407       ;; Make sure that the SYSTEM argument to 'lower-object' is honored.
1408       (mlet* %store-monad ((drv  (lower-object computed "mips64el-linux"))
1409                            (refs (references* (derivation-file-name drv))))
1410         (return (delete-duplicates
1411                  (filter-map (lambda (file)
1412                                (and (string-suffix? ".drv" file)
1413                                     (let ((drv (read-derivation-from-file
1414                                                 file)))
1415                                       (derivation-system drv))))
1416                              (cons (derivation-file-name drv)
1417                                    refs))))))))
1418
1419 (test-assert "lower-object & gexp-input-error?"
1420   (guard (c ((gexp-input-error? c)
1421              (gexp-error-invalid-input c)))
1422     (run-with-store %store
1423       (lower-object (current-module))
1424       #:guile-for-build (%guile-for-build))))
1425
1426 (test-assert "printer"
1427   (string-match "^#<gexp \\(string-append .*#<package coreutils.*\
1428  \"/bin/uname\"\\) [[:graph:]]+tests/gexp\\.scm:[0-9]+:[0-9]+ [[:xdigit:]]+>$"
1429                 (with-output-to-string
1430                   (lambda ()
1431                     (write
1432                      (gexp (string-append (ungexp coreutils)
1433                                           "/bin/uname")))))))
1434
1435 (test-assert "printer vs. ungexp-splicing"
1436   (string-match "^#<gexp .* [[:xdigit:]]+>$"
1437                 (with-output-to-string
1438                   (lambda ()
1439                     ;; #~(begin #$@#~())
1440                     (write
1441                      (gexp (begin (ungexp-splicing (gexp ())))))))))
1442
1443 (test-equal "sugar"
1444   '(gexp (foo (ungexp bar) (ungexp baz "out")
1445               (ungexp (chbouib 42))
1446               (ungexp-splicing (list x y z))
1447               (ungexp-native foo) (ungexp-native foo "out")
1448               (ungexp-native (chbouib 42))
1449               (ungexp-native-splicing (list x y z))))
1450   '#~(foo #$bar #$baz:out #$(chbouib 42) #$@(list x y z)
1451           #+foo #+foo:out #+(chbouib 42) #+@(list x y z)))
1452
1453 (test-assertm "gexp->file, cross-compilation"
1454   (mlet* %store-monad ((target -> "aarch64-linux-gnu")
1455                        (exp    -> (gexp (list (ungexp coreutils))))
1456                        (xdrv      (gexp->file "foo" exp #:target target))
1457                        (refs      (references*
1458                                    (derivation-file-name xdrv)))
1459                        (xcu       (package->cross-derivation coreutils
1460                                                              target))
1461                        (cu        (package->derivation coreutils)))
1462     (return (and (member (derivation-file-name xcu) refs)
1463                  (not (member (derivation-file-name cu) refs))))))
1464
1465 (test-assertm "gexp->file, cross-compilation with default target"
1466   (mlet* %store-monad ((target -> "aarch64-linux-gnu")
1467                        (_         (set-current-target target))
1468                        (exp    -> (gexp (list (ungexp coreutils))))
1469                        (xdrv      (gexp->file "foo" exp))
1470                        (refs      (references*
1471                                    (derivation-file-name xdrv)))
1472                        (xcu       (package->cross-derivation coreutils
1473                                                              target))
1474                        (cu        (package->derivation coreutils)))
1475     (return (and (member (derivation-file-name xcu) refs)
1476                  (not (member (derivation-file-name cu) refs))))))
1477
1478 (test-assertm "gexp->script, cross-compilation"
1479   (mlet* %store-monad ((target -> "aarch64-linux-gnu")
1480                        (exp    -> (gexp (list (ungexp coreutils))))
1481                        (xdrv      (gexp->script "foo" exp #:target target))
1482                        (refs      (references*
1483                                    (derivation-file-name xdrv)))
1484                        (xcu       (package->cross-derivation coreutils
1485                                                              target))
1486                        (cu        (package->derivation coreutils)))
1487     (return (and (member (derivation-file-name xcu) refs)
1488                  (not (member (derivation-file-name cu) refs))))))
1489
1490 (test-assertm "gexp->script, cross-compilation with default target"
1491   (mlet* %store-monad ((target -> "aarch64-linux-gnu")
1492                        (_         (set-current-target target))
1493                        (exp    -> (gexp (list (ungexp coreutils))))
1494                        (xdrv      (gexp->script "foo" exp))
1495                        (refs      (references*
1496                                    (derivation-file-name xdrv)))
1497                        (xcu       (package->cross-derivation coreutils
1498                                                              target))
1499                        (cu        (package->derivation coreutils)))
1500     (return (and (member (derivation-file-name xcu) refs)
1501                  (not (member (derivation-file-name cu) refs))))))
1502
1503 (test-end "gexp")
1504
1505 ;; Local Variables:
1506 ;; eval: (put 'test-assertm 'scheme-indent-function 1)
1507 ;; End: