tests/gexp.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (test-gexp)
  20   #:use-module (guix store)
  21   #:use-module (guix monads)
  22   #:use-module (guix gexp)
  23   #:use-module (guix derivations)
  24   #:use-module (guix packages)
  25   #:use-module (guix tests)
  26   #:use-module (gnu packages)
  27   #:use-module (gnu packages base)
  28   #:use-module (gnu packages bootstrap)
  29   #:use-module (srfi srfi-1)
  30   #:use-module (srfi srfi-34)
  31   #:use-module (srfi srfi-64)
  32   #:use-module (rnrs io ports)
  33   #:use-module (ice-9 match)
  34   #:use-module (ice-9 regex)
  35   #:use-module (ice-9 popen))
  36
  37 ;; Test the (guix gexp) module.
  38
  39 (define %store
  40   (open-connection-for-tests))
  41
  42 ;; For white-box testing.
  43 (define gexp-inputs (@@ (guix gexp) gexp-inputs))
  44 (define gexp-native-inputs (@@ (guix gexp) gexp-native-inputs))
  45 (define gexp->sexp  (@@ (guix gexp) gexp->sexp))
  46
  47 (define* (gexp->sexp* exp #:optional target)
  48   (run-with-store %store (gexp->sexp exp
  49                                      #:target target)
  50                   #:guile-for-build (%guile-for-build)))
  51
  52 (define-syntax-rule (test-assertm name exp)
  53   (test-assert name
  54     (run-with-store %store exp
  55                     #:guile-for-build (%guile-for-build))))
  56
  57 \f
  58 (test-begin "gexp")
  59
  60 (test-equal "no refs"
  61   '(display "hello!")
  62   (let ((exp (gexp (display "hello!"))))
  63     (and (gexp? exp)
  64          (null? (gexp-inputs exp))
  65          (gexp->sexp* exp))))
  66
  67 (test-equal "unquote"
  68   '(display `(foo ,(+ 2 3)))
  69   (let ((exp (gexp (display `(foo ,(+ 2 3))))))
  70     (and (gexp? exp)
  71          (null? (gexp-inputs exp))
  72          (gexp->sexp* exp))))
  73
  74 (test-assert "one input package"
  75   (let ((exp (gexp (display (ungexp coreutils)))))
  76     (and (gexp? exp)
  77          (match (gexp-inputs exp)
  78            (((p "out"))
  79             (eq? p coreutils)))
  80          (equal? `(display ,(derivation->output-path
  81                              (package-derivation %store coreutils)))
  82                  (gexp->sexp* exp)))))
  83
  84 (test-assert "one input origin"
  85   (let ((exp (gexp (display (ungexp (package-source coreutils))))))
  86     (and (gexp? exp)
  87          (match (gexp-inputs exp)
  88            (((o "out"))
  89             (eq? o (package-source coreutils))))
  90          (equal? `(display ,(derivation->output-path
  91                              (package-source-derivation
  92                               %store (package-source coreutils))))
  93                  (gexp->sexp* exp)))))
  94
  95 (test-assert "same input twice"
  96   (let ((exp (gexp (begin
  97                      (display (ungexp coreutils))
  98                      (display (ungexp coreutils))))))
  99     (and (gexp? exp)
 100          (match (gexp-inputs exp)
 101            (((p "out"))
 102             (eq? p coreutils)))
 103          (let ((e `(display ,(derivation->output-path
 104                               (package-derivation %store coreutils)))))
 105            (equal? `(begin ,e ,e) (gexp->sexp* exp))))))
 106
 107 (test-assert "two input packages, one derivation, one file"
 108   (let* ((drv (build-expression->derivation
 109                %store "foo" 'bar
 110                #:guile-for-build (package-derivation %store %bootstrap-guile)))
 111          (txt (add-text-to-store %store "foo" "Hello, world!"))
 112          (exp (gexp (begin
 113                       (display (ungexp coreutils))
 114                       (display (ungexp %bootstrap-guile))
 115                       (display (ungexp drv))
 116                       (display (ungexp txt))))))
 117     (define (match-input thing)
 118       (match-lambda
 119        ((drv-or-pkg _ ...)
 120         (eq? thing drv-or-pkg))))
 121
 122     (and (gexp? exp)
 123          (= 4 (length (gexp-inputs exp)))
 124          (every (lambda (input)
 125                   (find (match-input input) (gexp-inputs exp)))
 126                 (list drv coreutils %bootstrap-guile txt))
 127          (let ((e0 `(display ,(derivation->output-path
 128                                (package-derivation %store coreutils))))
 129                (e1 `(display ,(derivation->output-path
 130                                (package-derivation %store %bootstrap-guile))))
 131                (e2 `(display ,(derivation->output-path drv)))
 132                (e3 `(display ,txt)))
 133            (equal? `(begin ,e0 ,e1 ,e2 ,e3) (gexp->sexp* exp))))))
 134
 135 (test-assert "ungexp + ungexp-native"
 136   (let* ((exp    (gexp (list (ungexp-native %bootstrap-guile)
 137                              (ungexp coreutils)
 138                              (ungexp-native glibc)
 139                              (ungexp binutils))))
 140          (target "mips64el-linux")
 141          (guile  (derivation->output-path
 142                   (package-derivation %store %bootstrap-guile)))
 143          (cu     (derivation->output-path
 144                   (package-cross-derivation %store coreutils target)))
 145          (libc   (derivation->output-path
 146                   (package-derivation %store glibc)))
 147          (bu     (derivation->output-path
 148                   (package-cross-derivation %store binutils target))))
 149     (and (lset= equal?
 150                 `((,%bootstrap-guile "out") (,glibc "out"))
 151                 (gexp-native-inputs exp))
 152          (lset= equal?
 153                 `((,coreutils "out") (,binutils "out"))
 154                 (gexp-inputs exp))
 155          (equal? `(list ,guile ,cu ,libc ,bu)
 156                  (gexp->sexp* exp target)))))
 157
 158 (test-assert "input list"
 159   (let ((exp   (gexp (display
 160                       '(ungexp (list %bootstrap-guile coreutils)))))
 161         (guile (derivation->output-path
 162                 (package-derivation %store %bootstrap-guile)))
 163         (cu    (derivation->output-path
 164                 (package-derivation %store coreutils))))
 165     (and (lset= equal?
 166                 `((,%bootstrap-guile "out") (,coreutils "out"))
 167                 (gexp-inputs exp))
 168          (equal? `(display '(,guile ,cu))
 169                  (gexp->sexp* exp)))))
 170
 171 (test-assert "input list + ungexp-native"
 172   (let* ((target "mips64el-linux")
 173          (exp   (gexp (display
 174                        (cons '(ungexp-native (list %bootstrap-guile coreutils))
 175                              '(ungexp (list glibc binutils))))))
 176          (guile (derivation->output-path
 177                  (package-derivation %store %bootstrap-guile)))
 178          (cu    (derivation->output-path
 179                  (package-derivation %store coreutils)))
 180          (xlibc (derivation->output-path
 181                  (package-cross-derivation %store glibc target)))
 182          (xbu   (derivation->output-path
 183                  (package-cross-derivation %store binutils target))))
 184     (and (lset= equal?
 185                 `((,%bootstrap-guile "out") (,coreutils "out"))
 186                 (gexp-native-inputs exp))
 187          (lset= equal?
 188                 `((,glibc "out") (,binutils "out"))
 189                 (gexp-inputs exp))
 190          (equal? `(display (cons '(,guile ,cu) '(,xlibc ,xbu)))
 191                  (gexp->sexp* exp target)))))
 192
 193 (test-assert "input list splicing"
 194   (let* ((inputs  (list (list glibc "debug") %bootstrap-guile))
 195          (outputs (list (derivation->output-path
 196                          (package-derivation %store glibc)
 197                          "debug")
 198                         (derivation->output-path
 199                          (package-derivation %store %bootstrap-guile))))
 200          (exp     (gexp (list (ungexp-splicing (cons (+ 2 3) inputs))))))
 201     (and (lset= equal?
 202                 `((,glibc "debug") (,%bootstrap-guile "out"))
 203                 (gexp-inputs exp))
 204          (equal? (gexp->sexp* exp)
 205                  `(list ,@(cons 5 outputs))))))
 206
 207 (test-assert "input list splicing + ungexp-native-splicing"
 208   (let* ((inputs (list (list glibc "debug") %bootstrap-guile))
 209          (exp    (gexp (list (ungexp-native-splicing (cons (+ 2 3) inputs))))))
 210     (and (lset= equal?
 211                 `((,glibc "debug") (,%bootstrap-guile "out"))
 212                 (gexp-native-inputs exp))
 213          (null? (gexp-inputs exp))
 214          (equal? (gexp->sexp* exp)                ;native
 215                  (gexp->sexp* exp "mips64el-linux")))))
 216
 217 (test-assertm "gexp->file"
 218   (mlet* %store-monad ((exp -> (gexp (display (ungexp %bootstrap-guile))))
 219                        (guile  (package-file %bootstrap-guile))
 220                        (sexp   (gexp->sexp exp))
 221                        (drv    (gexp->file "foo" exp))
 222                        (out -> (derivation->output-path drv))
 223                        (done   (built-derivations (list drv)))
 224                        (refs   ((store-lift references) out)))
 225     (return (and (equal? sexp (call-with-input-file out read))
 226                  (equal? (list guile) refs)))))
 227
 228 (test-assertm "gexp->derivation"
 229   (mlet* %store-monad ((file    (text-file "foo" "Hello, world!"))
 230                        (exp ->  (gexp
 231                                  (begin
 232                                    (mkdir (ungexp output))
 233                                    (chdir (ungexp output))
 234                                    (symlink
 235                                     (string-append (ungexp %bootstrap-guile)
 236                                                    "/bin/guile")
 237                                     "foo")
 238                                    (symlink (ungexp file)
 239                                             (ungexp output "2nd")))))
 240                        (drv     (gexp->derivation "foo" exp))
 241                        (out ->  (derivation->output-path drv))
 242                        (out2 -> (derivation->output-path drv "2nd"))
 243                        (done    (built-derivations (list drv)))
 244                        (refs    ((store-lift references) out))
 245                        (refs2   ((store-lift references) out2))
 246                        (guile   (package-file %bootstrap-guile "bin/guile")))
 247     (return (and (string=? (readlink (string-append out "/foo")) guile)
 248                  (string=? (readlink out2) file)
 249                  (equal? refs (list (dirname (dirname guile))))
 250                  (equal? refs2 (list file))))))
 251
 252 (test-assertm "gexp->derivation, composed gexps"
 253   (mlet* %store-monad ((exp0 -> (gexp (begin
 254                                         (mkdir (ungexp output))
 255                                         (chdir (ungexp output)))))
 256                        (exp1 -> (gexp (symlink
 257                                        (string-append (ungexp %bootstrap-guile)
 258                                                       "/bin/guile")
 259                                        "foo")))
 260                        (exp  -> (gexp (begin (ungexp exp0) (ungexp exp1))))
 261                        (drv     (gexp->derivation "foo" exp))
 262                        (out ->  (derivation->output-path drv))
 263                        (done    (built-derivations (list drv)))
 264                        (guile   (package-file %bootstrap-guile "bin/guile")))
 265     (return (string=? (readlink (string-append out "/foo"))
 266                       guile))))
 267
 268 (test-assertm "gexp->derivation, default system"
 269   ;; The default system should be the one at '>>=' time, not the one at
 270   ;; invocation time.  See <http://bugs.gnu.org/18002>.
 271   (let ((system (%current-system))
 272         (mdrv   (parameterize ((%current-system "foobar64-linux"))
 273                   (gexp->derivation "foo"
 274                                     (gexp
 275                                      (mkdir (ungexp output)))))))
 276     (mlet %store-monad ((drv mdrv))
 277       (return (string=? system (derivation-system drv))))))
 278
 279 (test-assertm "gexp->derivation, cross-compilation"
 280   (mlet* %store-monad ((target -> "mips64el-linux")
 281                        (exp    -> (gexp (list (ungexp coreutils)
 282                                               (ungexp output))))
 283                        (xdrv      (gexp->derivation "foo" exp
 284                                                     #:target target))
 285                        (refs      ((store-lift references)
 286                                    (derivation-file-name xdrv)))
 287                        (xcu       (package->cross-derivation coreutils
 288                                                              target))
 289                        (cu        (package->derivation coreutils)))
 290     (return (and (member (derivation-file-name xcu) refs)
 291                  (not (member (derivation-file-name cu) refs))))))
 292
 293 (test-assertm "gexp->derivation, ungexp-native"
 294   (mlet* %store-monad ((target -> "mips64el-linux")
 295                        (exp    -> (gexp (list (ungexp-native coreutils)
 296                                               (ungexp output))))
 297                        (xdrv      (gexp->derivation "foo" exp
 298                                                     #:target target))
 299                        (drv       (gexp->derivation "foo" exp)))
 300     (return (string=? (derivation-file-name drv)
 301                       (derivation-file-name xdrv)))))
 302
 303 (test-assertm "gexp->derivation, ungexp + ungexp-native"
 304   (mlet* %store-monad ((target -> "mips64el-linux")
 305                        (exp    -> (gexp (list (ungexp-native coreutils)
 306                                               (ungexp glibc)
 307                                               (ungexp output))))
 308                        (xdrv      (gexp->derivation "foo" exp
 309                                                     #:target target))
 310                        (refs      ((store-lift references)
 311                                    (derivation-file-name xdrv)))
 312                        (xglibc    (package->cross-derivation glibc target))
 313                        (cu        (package->derivation coreutils)))
 314     (return (and (member (derivation-file-name cu) refs)
 315                  (member (derivation-file-name xglibc) refs)))))
 316
 317 (test-assertm "gexp->derivation, ungexp-native + composed gexps"
 318   (mlet* %store-monad ((target -> "mips64el-linux")
 319                        (exp0   -> (gexp (list 1 2
 320                                               (ungexp coreutils))))
 321                        (exp    -> (gexp (list 0 (ungexp-native exp0))))
 322                        (xdrv      (gexp->derivation "foo" exp
 323                                                     #:target target))
 324                        (drv       (gexp->derivation "foo" exp)))
 325     (return (string=? (derivation-file-name drv)
 326                       (derivation-file-name xdrv)))))
 327
 328 (test-assertm "gexp->derivation, store copy"
 329   (let ((build-one #~(call-with-output-file #$output
 330                        (lambda (port)
 331                          (display "This is the one." port))))
 332         (build-two (lambda (one)
 333                      #~(begin
 334                          (mkdir #$output)
 335                          (symlink #$one (string-append #$output "/one"))
 336                          (call-with-output-file (string-append #$output "/two")
 337                            (lambda (port)
 338                              (display "This is the second one." port))))))
 339         (build-drv #~(begin
 340                        (use-modules (guix build store-copy))
 341
 342                        (mkdir #$output)
 343                        (populate-store '("graph") #$output))))
 344     (mlet* %store-monad ((one (gexp->derivation "one" build-one))
 345                          (two (gexp->derivation "two" (build-two one)))
 346                          (drv (gexp->derivation "store-copy" build-drv
 347                                                 #:references-graphs
 348                                                 `(("graph" ,two))
 349                                                 #:modules
 350                                                 '((guix build store-copy)
 351                                                   (guix build utils))))
 352                          (ok? (built-derivations (list drv)))
 353                          (out -> (derivation->output-path drv)))
 354       (let ((one (derivation->output-path one))
 355             (two (derivation->output-path two)))
 356         (return (and ok?
 357                      (file-exists? (string-append out "/" one))
 358                      (file-exists? (string-append out "/" two))
 359                      (file-exists? (string-append out "/" two "/two"))
 360                      (string=? (readlink (string-append out "/" two "/one"))
 361                                one)))))))
 362
 363 (test-assertm "gexp->derivation #:references-graphs"
 364   (mlet* %store-monad
 365       ((one (text-file "one" "hello, world"))
 366        (two (gexp->derivation "two"
 367                               #~(symlink #$one #$output:chbouib)))
 368        (drv (gexp->derivation "ref-graphs"
 369                               #~(begin
 370                                   (use-modules (guix build store-copy))
 371                                   (with-output-to-file #$output
 372                                     (lambda ()
 373                                       (write (call-with-input-file "guile"
 374                                                read-reference-graph))))
 375                                   (with-output-to-file #$output:one
 376                                     (lambda ()
 377                                       (write (call-with-input-file "one"
 378                                                read-reference-graph))))
 379                                   (with-output-to-file #$output:two
 380                                     (lambda ()
 381                                       (write (call-with-input-file "two"
 382                                                read-reference-graph)))))
 383                               #:references-graphs `(("one" ,one)
 384                                                     ("two" ,two "chbouib")
 385                                                     ("guile" ,%bootstrap-guile))
 386                               #:modules '((guix build store-copy)
 387                                           (guix build utils))))
 388        (ok? (built-derivations (list drv)))
 389        (guile-drv  (package->derivation %bootstrap-guile))
 390        (g-one   -> (derivation->output-path drv "one"))
 391        (g-two   -> (derivation->output-path drv "two"))
 392        (g-guile -> (derivation->output-path drv)))
 393     (return (and ok?
 394                  (equal? (call-with-input-file g-one read) (list one))
 395                  (equal? (call-with-input-file g-two read)
 396                          (list one (derivation->output-path two "chbouib")))
 397                  (equal? (call-with-input-file g-guile read)
 398                          (list (derivation->output-path guile-drv)))))))
 399
 400 (test-assertm "gexp->derivation #:allowed-references"
 401   (mlet %store-monad ((drv (gexp->derivation "allowed-refs"
 402                                              #~(begin
 403                                                  (mkdir #$output)
 404                                                  (chdir #$output)
 405                                                  (symlink #$output "self")
 406                                                  (symlink #$%bootstrap-guile
 407                                                           "guile"))
 408                                              #:allowed-references
 409                                              (list "out" %bootstrap-guile))))
 410     (built-derivations (list drv))))
 411
 412 (test-assert "gexp->derivation #:allowed-references, disallowed"
 413   (let ((drv (run-with-store %store
 414                (gexp->derivation "allowed-refs"
 415                                  #~(begin
 416                                      (mkdir #$output)
 417                                      (chdir #$output)
 418                                      (symlink #$%bootstrap-guile "guile"))
 419                                  #:allowed-references '()))))
 420     (guard (c ((nix-protocol-error? c) #t))
 421       (build-derivations %store (list drv))
 422       #f)))
 423
 424 (define shebang
 425   (string-append "#!" (derivation->output-path (%guile-for-build))
 426                  "/bin/guile --no-auto-compile"))
 427
 428 ;; If we're going to hit the silly shebang limit (128 chars on Linux-based
 429 ;; systems), then skip the following test.
 430 (test-skip (if (> (string-length shebang) 127) 1 0))
 431
 432 (test-assertm "gexp->script"
 433   (mlet* %store-monad ((n ->   (random (expt 2 50)))
 434                        (exp -> (gexp
 435                                 (system*
 436                                  (string-append (ungexp %bootstrap-guile)
 437                                                 "/bin/guile")
 438                                  "-c" (object->string
 439                                        '(display (expt (ungexp n) 2))))))
 440                        (drv    (gexp->script "guile-thing" exp
 441                                              #:guile %bootstrap-guile))
 442                        (out -> (derivation->output-path drv))
 443                        (done   (built-derivations (list drv))))
 444     (let* ((pipe  (open-input-pipe out))
 445            (str   (get-string-all pipe)))
 446       (return (and (zero? (close-pipe pipe))
 447                    (= (expt n 2) (string->number str)))))))
 448
 449 (test-assert "text-file*"
 450   (let ((references (store-lift references)))
 451     (run-with-store %store
 452       (mlet* %store-monad
 453           ((drv  (package->derivation %bootstrap-guile))
 454            (guile -> (derivation->output-path drv))
 455            (file (text-file "bar" "This is bar."))
 456            (text (text-file* "foo"
 457                              %bootstrap-guile "/bin/guile "
 458                              `(,%bootstrap-guile "out") "/bin/guile "
 459                              drv "/bin/guile "
 460                              file))
 461            (done (built-derivations (list text)))
 462            (out -> (derivation->output-path text))
 463            (refs (references out)))
 464         ;; Make sure we get the right references and the right content.
 465         (return (and (lset= string=? refs (list guile file))
 466                      (equal? (call-with-input-file out get-string-all)
 467                              (string-append guile "/bin/guile "
 468                                             guile "/bin/guile "
 469                                             guile "/bin/guile "
 470                                             file)))))
 471       #:guile-for-build (package-derivation %store %bootstrap-guile))))
 472
 473 (test-assert "printer"
 474   (string-match "^#<gexp \\(string-append .*#<package coreutils.*\
 475  \"/bin/uname\"\\) [[:xdigit:]]+>$"
 476                 (with-output-to-string
 477                   (lambda ()
 478                     (write
 479                      (gexp (string-append (ungexp coreutils)
 480                                           "/bin/uname")))))))
 481
 482 (test-assert "printer vs. ungexp-splicing"
 483   (string-match "^#<gexp .* [[:xdigit:]]+>$"
 484                 (with-output-to-string
 485                   (lambda ()
 486                     ;; #~(begin #$@#~())
 487                     (write
 488                      (gexp (begin (ungexp-splicing (gexp ())))))))))
 489
 490 (test-equal "sugar"
 491   '(gexp (foo (ungexp bar) (ungexp baz "out")
 492               (ungexp (chbouib 42))
 493               (ungexp-splicing (list x y z))
 494               (ungexp-native foo) (ungexp-native foo "out")
 495               (ungexp-native (chbouib 42))
 496               (ungexp-native-splicing (list x y z))))
 497   '#~(foo #$bar #$baz:out #$(chbouib 42) #$@(list x y z)
 498           #+foo #+foo:out #+(chbouib 42) #+@(list x y z)))
 499
 500 (test-end "gexp")
 501
 502 \f
 503 (exit (= (test-runner-fail-count (test-runner-current)) 0))
 504
 505 ;; Local Variables:
 506 ;; eval: (put 'test-assertm 'scheme-indent-function 1)
 507 ;; End: