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