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