;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014-2023 Ludovic Courtès ;;; Copyright © 2021-2022 Maxime Devos ;;; ;;; This file is part of GNU Guix. ;;; ;;; GNU Guix is free software; you can redistribute it and/or modify it ;;; under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or (at ;;; your option) any later version. ;;; ;;; GNU Guix is distributed in the hope that it will be useful, but ;;; WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with GNU Guix. If not, see . (define-module (test-gexp) #:use-module (guix store) #:use-module (guix monads) #:use-module (guix gexp) #:use-module ((guix grafts)
aboutsummaryrefslogtreecommitdiff
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2015, 2016, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
;;; Copyright © 2021 Brendan Tildesley <mail@brendan.scot>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.


(define-module (test build-utils)
  #:use-module (guix tests)
  #:use-module (guix build utils)
  #:use-module ((guix utils)
                #:select (%current-system call-with-temporary-directory))
  #:use-module (gnu packages)
  #:use-module (gnu packages bootstrap)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (srfi srfi-64)
  #:use-module (rnrs io ports)
  #:use-module (ice-9 popen))


(test-begin "build-utils")

(test-equal "alist-cons-before"
  '((a . 1) (x . 42) (b . 2) (c . 3))
  (alist-cons-before 'b 'x 42 '((a . 1) (b . 2) (c . 3))))

(test-assert "alist-cons-before, reference not found"
  (not (false-if-exception
        (alist-cons-before 'z 'x 42 '((a . 1) (b . 2) (c . 3))))))

(test-equal "alist-cons-after"
  '((a . 1) (b . 2) (x . 42) (c . 3))
  (alist-cons-after 'b 'x 42 '((a . 1) (b . 2) (c . 3))))

(test-assert "alist-cons-after, reference not found"
  (not (false-if-exception
        (alist-cons-after 'z 'x 42 '((a . 1) (b . 2) (c . 3))))))

(test-equal "alist-replace"
  '((a . 1) (b . 77) (c . 3))
  (alist-replace 'b 77 '((a . 1) (b . 2) (c . 3))))

(test-assert "alist-replace, key not found"
  (not (false-if-exception
        (alist-replace 'z 77 '((a . 1) (b . 2) (c . 3))))))

(test-equal "fold-port-matches"
  (make-list 3 "Guix")
  (call-with-input-string "Guix is cool, Guix rocks, and it uses Guile, Guix!"
    (lambda (port)
      (fold-port-matches cons '() "Guix" port))))

(test-equal "fold-port-matches, trickier"
  (reverse '("Guix" "guix" "Guix" "guiX" "Guix"))
  (call-with-input-string "Guix, guix, GuiGuixguiX, Guix"
    (lambda (port)
      (fold-port-matches cons '()
                         (list (char-set #\G #\g)
                               (char-set #\u)
                               (char-set #\i)
                               (char-set #\x #\X))
                         port))))

(test-equal "fold-port-matches, with unmatched chars"
  '("Guix" #\, #\space
    "guix" #\, #\space
    #\G #\u #\i "Guix" "guiX" #\, #\space
    "Guix")
  (call-with-input-string "Guix, guix, GuiGuixguiX, Guix"
    (lambda (port)
      (reverse
       (fold-port-matches cons '()
                          (list (char-set #\G #\g)
                                (char-set #\u)
                                (char-set #\i)
                                (char-set #\x #\X))
                          port
                          cons)))))

(test-equal "wrap-program, one input, multiple calls"
  "hello world\n"
  (call-with-temporary-directory
   (lambda (directory)
     (let ((bash (search-bootstrap-binary "bash" (%current-system)))
           (foo  (string-append directory "/foo")))

       (call-with-output-file foo
         (lambda (p)
           (format p
                   "#!~a~%echo \"${GUIX_FOO} ${GUIX_BAR}\"~%"
                   bash)))
       (chmod foo #o777)

       ;; wrap-program uses `which' to find bash for the wrapper shebang, but
       ;; it can't know about the bootstrap bash in the store, since it's not
       ;; named "bash".  Help it out a bit by providing a symlink it this
       ;; package's output.
       (with-environment-variable "PATH" (dirname bash)
         (wrap-program foo `("GUIX_FOO" prefix ("hello")))
         (wrap-program foo `("GUIX_BAR" prefix ("world")))

         ;; The bootstrap Bash is linked against an old libc and would abort
         ;; with an assertion failure when trying to load incompatible locale
         ;; data.
         (unsetenv "LOCPATH")

         (let* ((pipe (open-input-pipe foo))
                (str  (get-string-all pipe)))
           (with-directory-excursion directory
             (for-each delete-file '("foo" ".foo-real")))
           (and (zero? (close-pipe pipe))
                str)))))))

(test-assert "invoke/quiet, success"
  (begin
    (invoke/quiet "true")
    #t))

(test-assert "invoke/quiet, failure"
  (guard (c ((message-condition? c)
             (string-contains (condition-message c) "This is an error.")))
    (invoke/quiet "sh" "-c" "echo This is an error. ; false")
    #f))

(test-assert "invoke/quiet, failure, message on stderr"
  (guard (c ((message-condition? c)
             (string-contains (condition-message c)
                              "This is another error.")))
    (invoke/quiet "sh" "-c" "echo This is another error. >&2 ; false")
    #f))

(let ((script-contents "\
#!/anything/cabbage-bash-1.2.3/bin/sh

echo hello world"))

  (test-equal "wrap-script, simple case"
    (string-append
     (format #f "\
#!~a --no-auto-compile
#!#; Guix wrapper
#\\-~s
#\\-~s
"
             (which "guile")
             '(begin (let ((current (getenv "GUIX_FOO")))
                       (setenv "GUIX_FOO"
                               (if current
                                   (string-append "/some/path:/some/other/path"
                                                  ":" current)
                                   "/some/path:/some/other/path"))))
             '(let ((cl (command-line)))
                (apply execl "/anything/cabbage-bash-1.2.3/bin/sh"
                       (car cl) (append (quote ()) cl))))
     script-contents)
    (call-with-temporary-directory
     (lambda (directory)
       (let ((script-file-name (string-append directory "/foo")))
         (call-with-output-file script-file-name
           (lambda (port)
             (display script-contents port)))
         (chmod script-file-name #o777)
         (wrap-script script-file-name
                      `("GUIX_FOO" prefix ("/some/path"
                                           "/some/other/path")))
         (let ((str (call-with-input-file script-file-name get-string-all)))
           (with-directory-excursion directory
             (delete-file "foo"))
           str))))))

(let ((script-contents "\
#!/anything/cabbage-bash-1.2.3/bin/python3 -and -args
# vim:fileencoding=utf-8
print('hello world')"))

  (test-equal "wrap-script, with encoding declaration"
    (string-append
     (format #f "\
#!MYGUILE --no-auto-compile
#!#; # vim:fileencoding=utf-8
#\\-~s
#\\-~s
"
             '(begin (let ((current (getenv "GUIX_FOO")))
                       (setenv "GUIX_FOO"
                               (if current
                                   (string-append "/some/path:/some/other/path"
                                                  ":" current)
                                   "/some/path:/some/other/path"))))
             `(let ((cl (command-line)))
                (apply execl "/anything/cabbage-bash-1.2.3/bin/python3"
                       (car cl)
                       (append '("-and" "-args") cl))))
     script-contents)
    (call-with-temporary-directory
     (lambda (directory)
       (let ((script-file-name (string-append directory "/foo")))
         (call-with-output-file script-file-name
           (lambda (port)
             (format port script-contents)))
         (chmod script-file-name #o777)

         (wrap-script script-file-name
                      #:guile "MYGUILE"
                      `("GUIX_FOO" prefix ("/some/path"
                                           "/some/other/path")))
         (let ((str (call-with-input-file script-file-name get-string-all)))
           (with-directory-excursion directory
             (delete-file "foo"))
           str))))))

(test-assert "wrap-script, raises condition"
  (call-with-temporary-directory
   (lambda (directory)
     (let ((script-file-name (string-append directory "/foo")))
       (call-with-output-file script-file-name
         (lambda (port)
           (format port "This is not a script")))
       (chmod script-file-name #o777)
       (guard (c ((wrap-error? c) #t))
         (wrap-script script-file-name
                      #:guile "MYGUILE"
                      `("GUIX_FOO" prefix ("/some/path"
                                           "/some/other/path")))
         #f)))))

(define (arg-test bash-args)
  (call-with-temporary-directory
   (lambda (directory)
     (let ((script-file-name (string-append directory "/bash-test.sh")))
       (call-with-output-file script-file-name
         (lambda (port)
           (display (string-append "\
#!" (which "bash") bash-args "
echo \"$#$0$*${A}\"")
                    port)))

       (display "Unwrapped script contents:\n")
       (call-with-input-file script-file-name
         (lambda (port) (display (get-string-all port))))
       (newline) (newline)
       (chmod script-file-name #o777)
       (setenv "A" "A")
       (let* ((run-script (lambda _
                            (open-pipe*
                             OPEN_READ
                             script-file-name "1" "2" "3 3" "4")))
              (pipe (run-script))
              (unwrapped-output (get-string-all pipe)))
         (close-pipe pipe)

         (wrap-script script-file-name `("A" = ("A\nA")))

         (display "Wrapped script contents:\n")
         (call-with-input-file script-file-name
           (lambda (port) (display (get-string-all port))))
         (newline) (newline)

         (let* ((pipe (run-script))
                (wrapped-output (get-string-all pipe)))
           (close-pipe pipe)
           (display "./bash-test.sh 1 2 3\\ 3 4 # Output:\n")
           (display unwrapped-output) (newline)
           (display "./bash-test.sh 1 2 3\\ 3 4 # Output (wrapped):\n")
           (display wrapped-output) (newline)
           (string=? (string-append unwrapped-output "A\n")
                     wrapped-output)))))))

(test-assert "wrap-script, argument handling"
  (arg-test ""))

(test-assert "wrap-script, argument handling, bash --norc"
  (arg-test " --norc"))

(test-equal "substitute*, text contains a NUL byte, UTF-8"
  "c\0d"
  (with-fluids ((%default-port-encoding "UTF-8")
                (%default-port-conversion-strategy 'error))
    ;; The GNU libc is locale sensitive.  Depending on the value of LANG, the
    ;; test could fail with "string contains #\\nul character: ~S" or "cannot
    ;; convert wide string to output locale".
    (setlocale LC_ALL "en_US.UTF-8")
    (call-with-temporary-output-file
     (lambda (file port)
       (format port "a\0b")
       (flush-output-port port)

       (substitute* file
         (("a") "c")
         (("b") "d"))

       (with-input-from-file file
         (lambda _
           (get-string-all (current-input-port))))))))

(test-equal "search-input-file: exception if not found"
  `((path)
    (file . "does-not-exist"))
  (guard (e ((search-error? e)
             `((path . ,(search-error-path e))
               (file . ,(search-error-file e)))))
    (search-input-file '() "does-not-exist")))

(test-equal "search-input-file: can find if existent"
  (which "guile")
  (search-input-file
    `(("guile/bin" . ,(dirname (which "guile"))))
    "guile"))

(test-equal "search-input-file: can search in multiple directories"
  (which "guile")
  (call-with-temporary-directory
    (lambda (directory)
      (search-input-file
        `(("irrelevant" . ,directory)
          ("guile/bin" . ,(dirname (which "guile"))))
        "guile"))))

(test-end)
generated by cgit
:bar))) (exp #~(symlink #$obj #$output)) (drv (run-with-store %store (lower-gexp exp)))) (pk 'oops! drv #f)))) (test-assert "gexp-input, as first-class input" ;; Insert a record in a gexp as a way to specify which output ;; of OBJ should be used. (let* ((obj (computed-file "foo" #~(mkdir #$output:bar))) (exp #~(list #$(gexp-input obj "bar"))) (drv (run-with-store %store (lower-object obj))) (item (derivation->output-path drv "bar")) (lexp (run-with-store %store (lower-gexp exp)))) (and (match (lowered-gexp-inputs lexp) ((input) (eq? (derivation-input-derivation input) drv))) (equal? (lowered-gexp-sexp lexp) `(list ,item))))) (test-assertm "with-parameters for %current-system" (mlet* %store-monad ((system -> (match (%current-system) ("aarch64-linux" "x86_64-linux") (_ "aarch64-linux"))) (drv (package->derivation coreutils system)) (obj -> (with-parameters ((%current-system system)) coreutils)) (result (lower-object obj))) (return (string=? (derivation-file-name drv) (derivation-file-name result))))) (test-assertm "with-parameters for %current-target-system" (mlet* %store-monad ((target -> "riscv64-linux-gnu") (drv (package->cross-derivation coreutils target)) (obj -> (with-parameters ((%current-target-system target)) coreutils)) (result (lower-object obj))) (return (string=? (derivation-file-name drv) (derivation-file-name result))))) (test-assert "with-parameters + file-append" (let* ((system (match (%current-system) ("aarch64-linux" "x86_64-linux") (_ "aarch64-linux"))) (drv (package-derivation %store coreutils system)) (param (make-parameter 7)) (exp #~(here we go #$(with-parameters ((%current-system system) (param 42)) (if (= (param) 42) (file-append coreutils "/bin/touch") %bootstrap-guile))))) (match (gexp->sexp* exp) (('here 'we 'go (? string? result)) (string=? result (string-append (derivation->output-path drv) "/bin/touch")))))) (test-equal "let-system" (list `(begin ,(%current-system) #t) '(system-binding) 'low '() '()) (let* ((exp #~(begin #$(let-system system system) #t)) (low (run-with-store %store (lower-gexp exp)))) (list (lowered-gexp-sexp low) (match (gexp-inputs exp) ((input) (and (eq? (struct-vtable (gexp-input-thing input)) (@@ (guix gexp) )) (string=? (gexp-input-output input) "out") '(system-binding))) (x x)) 'low (lowered-gexp-inputs low) (lowered-gexp-sources low)))) (test-equal "let-system, target" (list `(list ,(%current-system) #f) `(list ,(%current-system) "aarch64-linux-gnu")) (let ((exp #~(list #$@(let-system (system target) (list system target))))) (list (gexp->sexp* exp) (gexp->sexp* exp "aarch64-linux-gnu")))) (test-equal "let-system, ungexp-native, target" `(here it is: ,(%current-system) #f) (let ((exp #~(here it is: #+@(let-system (system target) (list system target))))) (gexp->sexp* exp "aarch64-linux-gnu"))) (test-equal "let-system, nested" (list `(system* ,(string-append "qemu-system-" (%current-system)) "-m" "256") '(system-binding)) (let ((exp #~(system* #+(let-system (system target) (file-append (@@ (gnu packages virtualization) qemu) "/bin/qemu-system-" system)) "-m" "256"))) (list (match (gexp->sexp* exp) (('system* command rest ...) `(system* ,(and (string-prefix? (%store-prefix) command) (basename command)) ,@rest)) (x x)) (match (gexp-inputs exp) ((input) (and (eq? (struct-vtable (gexp-input-thing input)) (@@ (guix gexp) )) (string=? (gexp-input-output input) "out") (gexp-input-native? input) '(system-binding))) (x x))))) (test-assert "let-system in file-append" (let ((mixed (file-append (let-system (system target) (if (not target) grep sed)) "/bin")) (grep (file-append grep "/bin")) (sed (file-append sed "/bin"))) (and (equal? (gexp->sexp* #~(list #$mixed)) (gexp->sexp* #~(list #$grep))) (equal? (gexp->sexp* #~(list #$mixed) "powerpc64le-linux-gnu") (gexp->sexp* #~(list #$sed) "powerpc64le-linux-gnu"))))) (test-assert "ungexp + ungexp-native" (let* ((exp (gexp (list (ungexp-native %bootstrap-guile) (ungexp coreutils) (ungexp-native glibc) (ungexp binutils)))) (target "mips64el-linux-gnu") (guile (derivation->output-path (package-derivation %store %bootstrap-guile))) (cu (derivation->output-path (package-cross-derivation %store coreutils target))) (libc (derivation->output-path (package-derivation %store glibc))) (bu (derivation->output-path (package-cross-derivation %store binutils target)))) (and (lset= equal? `((,%bootstrap-guile "out" #t) (,coreutils "out" #f) (,glibc "out" #t) (,binutils "out" #f)) (map gexp-input->tuple (gexp-inputs exp))) (equal? `(list ,guile ,cu ,libc ,bu) (gexp->sexp* exp target))))) (test-equal "ungexp + ungexp-native, nested" `((,%bootstrap-guile "out" #f) (,coreutils "out" #t)) (let* ((exp (gexp (list (ungexp-native (gexp (ungexp coreutils))) (ungexp %bootstrap-guile))))) (map gexp-input->tuple (gexp-inputs exp)))) (test-equal "ungexp + ungexp-native, nested, special mixture" `((,coreutils "out" #t)) (let* ((foo (gexp (foo (ungexp-native coreutils)))) (exp (gexp (bar (ungexp foo))))) (map gexp-input->tuple (gexp-inputs exp)))) (test-assert "input list" (let ((exp (gexp (display '(ungexp (list %bootstrap-guile coreutils))))) (guile (derivation->output-path (package-derivation %store %bootstrap-guile))) (cu (derivation->output-path (package-derivation %store coreutils)))) (and (lset= equal? `((,%bootstrap-guile "out" #f) (,coreutils "out" #f)) (map gexp-input->tuple (gexp-inputs exp))) (equal? `(display '(,guile ,cu)) (gexp->sexp* exp))))) (test-assert "input list + ungexp-native" (let* ((target "mips64el-linux-gnu") (exp (gexp (display (cons '(ungexp-native (list %bootstrap-guile coreutils)) '(ungexp (list glibc binutils)))))) (guile (derivation->output-path (package-derivation %store %bootstrap-guile))) (cu (derivation->output-path (package-derivation %store coreutils))) (xlibc (derivation->output-path (package-cross-derivation %store glibc target))) (xbu (derivation->output-path (package-cross-derivation %store binutils target)))) (and (lset= equal? `((,%bootstrap-guile "out" #t) (,coreutils "out" #t) (,glibc "out" #f) (,binutils "out" #f)) (map gexp-input->tuple (gexp-inputs exp))) (equal? `(display (cons '(,guile ,cu) '(,xlibc ,xbu))) (gexp->sexp* exp target))))) (test-assert "input list splicing" (let* ((inputs (list (gexp-input glibc "debug") %bootstrap-guile)) (outputs (list (derivation->output-path (package-derivation %store glibc) "debug") (derivation->output-path (package-derivation %store %bootstrap-guile)))) (exp (gexp (list (ungexp-splicing (cons (+ 2 3) inputs)))))) (and (lset= equal? `((,glibc "debug" #f) (,%bootstrap-guile "out" #f)) (map gexp-input->tuple (gexp-inputs exp))) (equal? (gexp->sexp* exp) `(list ,@(cons 5 outputs)))))) (test-assert "input list splicing + ungexp-native-splicing" (let* ((inputs (list (gexp-input glibc "debug" #:native? #t) %bootstrap-guile)) (exp (gexp (list (ungexp-native-splicing (cons (+ 2 3) inputs)))))) (and (lset= equal? `((,glibc "debug" #t) (,%bootstrap-guile "out" #t)) (map gexp-input->tuple (gexp-inputs exp))) (equal? (gexp->sexp* exp) ;native (gexp->sexp* exp "mips64el-linux"))))) (test-assert "gexp list splicing + ungexp-splicing" (let* ((inner (gexp (ungexp-native glibc))) (exp (gexp (list (ungexp-splicing (list inner)))))) (and (equal? `((,glibc "out" #t)) (map gexp-input->tuple (gexp-inputs exp))) (equal? (gexp->sexp* exp) ;native (gexp->sexp* exp "mips64el-linux"))))) (test-equal "output list" 2 (let ((exp (gexp (begin (mkdir (ungexp output)) (mkdir (ungexp output "bar")))))) (length (gexp-outputs exp)))) ;XXX: is private (test-assert "output list, combined gexps" (let* ((exp0 (gexp (mkdir (ungexp output)))) (exp1 (gexp (mkdir (ungexp output "foo")))) (exp2 (gexp (begin (display "hi!") (ungexp exp0) (ungexp exp1))))) (and (lset= equal? (append (gexp-outputs exp0) (gexp-outputs exp1)) (gexp-outputs exp2)) (= 2 (length (gexp-outputs exp2)))))) (test-equal "output list, combined gexps, duplicate output" 1 (let* ((exp0 (gexp (mkdir (ungexp output)))) (exp1 (gexp (begin (mkdir (ungexp output)) (ungexp exp0)))) (exp2 (gexp (begin (mkdir (ungexp output)) (ungexp exp1))))) (length (gexp-outputs exp2)))) (test-assert "output list + ungexp-splicing list, combined gexps" (let* ((exp0 (gexp (mkdir (ungexp output)))) (exp1 (gexp (mkdir (ungexp output "foo")))) (exp2 (gexp (begin (display "hi!") (ungexp-splicing (list exp0 exp1)))))) (and (lset= equal? (append (gexp-outputs exp0) (gexp-outputs exp1)) (gexp-outputs exp2)) (= 2 (length (gexp-outputs exp2)))))) (test-assertm "gexp->file" (mlet* %store-monad ((exp -> (gexp (display (ungexp %bootstrap-guile)))) (guile (package-file %bootstrap-guile)) (sexp (gexp->sexp exp (%current-system) #f)) (drv (gexp->file "foo" exp)) (out -> (derivation->output-path drv)) (done (built-derivations (list drv))) (refs (references* out))) (return (and (equal? sexp (call-with-input-file out read)) (equal? (list guile) refs))))) (test-assertm "gexp->file + file-append" (mlet* %store-monad ((exp -> #~#$(file-append %bootstrap-guile "/bin/guile")) (guile (package-file %bootstrap-guile)) (drv (gexp->file "foo" exp)) (out -> (derivation->output-path drv)) (done (built-derivations (list drv))) (refs (references* out))) (return (and (equal? (string-append guile "/bin/guile") (call-with-input-file out read)) (equal? (list guile) refs))))) (test-assertm "gexp->file + #:splice?" (mlet* %store-monad ((exp -> (list #~(define foo 'bar) #~(define guile #$%bootstrap-guile))) (guile (package-file %bootstrap-guile)) (drv (gexp->file "splice" exp #:splice? #t)) (out -> (derivation->output-path drv)) (done (built-derivations (list drv))) (refs (references* out))) (pk 'splice out) (return (and (equal? `((define foo 'bar) (define guile ,guile) ,(call-with-input-string "" read)) (call-with-input-file out (lambda (port) (list (read port) (read port) (read port))))) (equal? (list guile) refs))))) (test-assertm "gexp->derivation" (mlet* %store-monad ((file (text-file "foo" "Hello, world!")) (exp -> (gexp (begin (mkdir (ungexp output)) (chdir (ungexp output)) (symlink (string-append (ungexp %bootstrap-guile) "/bin/guile") "foo") (symlink (ungexp file) (ungexp output "2nd"))))) (drv (gexp->derivation "foo" exp)) (out -> (derivation->output-path drv)) (out2 -> (derivation->output-path drv "2nd")) (done (built-derivations (list drv))) (refs (references* out)) (refs2 (references* out2)) (guile (package-file %bootstrap-guile "bin/guile"))) (return (and (string=? (readlink (string-append out "/foo")) guile) (string=? (readlink out2) file) (equal? refs (list (dirname (dirname guile)))) (equal? refs2 (list file)) (null? (derivation-properties drv)))))) (test-assertm "gexp->derivation properties" (mlet %store-monad ((drv (gexp->derivation "foo" #~(mkdir #$output) #:properties '((type . test))))) (return (equal? '((type . test)) (derivation-properties drv))))) (test-assertm "gexp->derivation vs. grafts" (mlet* %store-monad ((graft? (set-grafting #f)) (p0 -> (dummy-package "dummy" (arguments '(#:implicit-inputs? #f)))) (r -> (package (inherit p0) (name "DuMMY"))) (p1 -> (package (inherit p0) (replacement r))) (exp0 -> (gexp (frob (ungexp p0) (ungexp output)))) (exp1 -> (gexp (frob (ungexp p1) (ungexp output)))) (void (set-guile-for-build %bootstrap-guile)) (drv0 (gexp->derivation "t" exp0 #:graft? #t)) (drv1 (gexp->derivation "t" exp1 #:graft? #t)) (drv1* (gexp->derivation "t" exp1 #:graft? #f)) (_ (set-grafting graft?))) (return (and (not (string=? (derivation->output-path drv0) (derivation->output-path drv1))) (string=? (derivation->output-path drv0) (derivation->output-path drv1*)))))) (test-assertm "gexp->derivation, composed gexps" (mlet* %store-monad ((exp0 -> (gexp (begin (mkdir (ungexp output)) (chdir (ungexp output))))) (exp1 -> (gexp (symlink (string-append (ungexp %bootstrap-guile) "/bin/guile") "foo"))) (exp -> (gexp (begin (ungexp exp0) (ungexp exp1)))) (drv (gexp->derivation "foo" exp)) (out -> (derivation->output-path drv)) (done (built-derivations (list drv))) (guile (package-file %bootstrap-guile "bin/guile"))) (return (string=? (readlink (string-append out "/foo")) guile)))) (test-assertm "gexp->derivation, default system" ;; The default system should be the one at '>>=' time, not the one at ;; invocation time. See . (let ((system (%current-system)) (mdrv (parameterize ((%current-system "foobar64-linux")) (gexp->derivation "foo" (gexp (mkdir (ungexp output))))))) (mlet %store-monad ((drv mdrv)) (return (string=? system (derivation-system drv)))))) (test-assertm "gexp->derivation, local-file" (mlet* %store-monad ((file -> (search-path %load-path "guix.scm")) (intd (interned-file file #:recursive? #f)) (local -> (local-file file)) (exp -> (gexp (begin (stat (ungexp local)) (symlink (ungexp local) (ungexp output))))) (drv (gexp->derivation "local-file" exp))) (mbegin %store-monad (built-derivations (list drv)) (return (string=? (readlink (derivation->output-path drv)) intd))))) (test-assertm "gexp->derivation, cross-compilation" (mlet* %store-monad ((target -> "mips64el-linux-gnu") (exp -> (gexp (list (ungexp coreutils) (ungexp output)))) (xdrv (gexp->derivation "foo" exp #:target target)) (refs (references* (derivation-file-name xdrv))) (xcu (package->cross-derivation coreutils target)) (cu (package->derivation coreutils))) (return (and (member (derivation-file-name xcu) refs) (not (member (derivation-file-name cu) refs)))))) (test-assertm "gexp->derivation, ungexp-native" (mlet* %store-monad ((target -> "mips64el-linux-gnu") (exp -> (gexp (list (ungexp-native coreutils) (ungexp output)))) (xdrv (gexp->derivation "foo" exp #:target target)) (drv (gexp->derivation "foo" exp))) (return (string=? (derivation-file-name drv) (derivation-file-name xdrv))))) (test-assertm "gexp->derivation, ungexp + ungexp-native" (mlet* %store-monad ((target -> "mips64el-linux-gnu") (exp -> (gexp (list (ungexp-native coreutils) (ungexp glibc) (ungexp output)))) (xdrv (gexp->derivation "foo" exp #:target target)) (refs (references* (derivation-file-name xdrv))) (xglibc (package->cross-derivation glibc target)) (cu (package->derivation coreutils))) (return (and (member (derivation-file-name cu) refs) (member (derivation-file-name xglibc) refs))))) (test-assertm "gexp->derivation, ungexp-native + composed gexps" (mlet* %store-monad ((target -> "mips64el-linux-gnu") (exp0 -> (gexp (list 1 2 (ungexp coreutils)))) (exp -> (gexp (list 0 (ungexp-native exp0)))) (xdrv (gexp->derivation "foo" exp #:target target)) (drv (gexp->derivation "foo" exp))) (return (string=? (derivation-file-name drv) (derivation-file-name xdrv))))) (test-assertm "gexp->derivation, store copy" (let ((build-one #~(call-with-output-file #$output (lambda (port) (display "This is the one." port)))) (build-two (lambda (one) #~(begin (mkdir #$output) (symlink #$one (string-append #$output "/one")) (call-with-output-file (string-append #$output "/two") (lambda (port) (display "This is the second one." port)))))) (build-drv (with-imported-modules '((guix build store-copy) (guix build syscalls) (guix progress) (guix records) (guix sets) (guix build utils)) #~(begin (use-modules (guix build store-copy) (guix build utils) (srfi srfi-1)) (define (canonical-file? file) ;; Copied from (guix tests). (let ((st (lstat file))) (or (not (string-prefix? (%store-directory) file)) (eq? 'symlink (stat:type st)) (and (= 1 (stat:mtime st)) (zero? (logand #o222 (stat:mode st))))))) (mkdir #$output) (populate-store '("graph") #$output #:deduplicate? #f) ;; Check whether 'populate-store' canonicalizes ;; permissions and timestamps. (unless (every canonical-file? (find-files #$output)) (error "not canonical!" #$output)))))) (mlet* %store-monad ((one (gexp->derivation "one" build-one)) (two (gexp->derivation "two" (build-two one))) (drv (gexp->derivation "store-copy" build-drv #:references-graphs `(("graph" ,two)))) (ok? (built-derivations (list drv))) (out -> (derivation->output-path drv))) (let ((one (derivation->output-path one)) (two (derivation->output-path two))) (return (and ok? (file-exists? (string-append out "/" one)) (file-exists? (string-append out "/" two)) (file-exists? (string-append out "/" two "/two")) (string=? (readlink (string-append out "/" two "/one")) one))))))) (test-assertm "imported-files" (mlet* %store-monad ((files -> `(("x" . ,(search-path %load-path "ice-9/q.scm")) ("a/b/c" . ,(search-path %load-path "guix/derivations.scm")) ("p/q" . ,(search-path %load-path "guix.scm")) ("p/z" . ,(search-path %load-path "guix/store.scm")))) (dir (imported-files files))) (mbegin %store-monad (return (every (match-lambda ((path . source) (equal? (call-with-input-file (string-append dir "/" path) get-bytevector-all) (call-with-input-file source get-bytevector-all)))) files))))) (test-assertm "imported-files with file-like objects" (mlet* %store-monad ((plain -> (plain-file "foo" "bar!")) (q-scm -> (search-path %load-path "ice-9/q.scm")) (files -> `(("a/b/c" . ,q-scm) ("p/q" . ,plain))) (drv (imported-files files))) (mbegin %store-monad (built-derivations (list (pk 'drv drv))) (mlet %store-monad ((dir -> (derivation->output-path drv)) (plain* (text-file "foo" "bar!")) (q-scm* (interned-file q-scm "c"))) (return (and (file=? (string-append dir "/a/b/c") q-scm* stat) (file=? (string-append dir "/p/q") plain* stat))))))) (test-equal "gexp-modules & ungexp" '((bar) (foo)) ((@@ (guix gexp) gexp-modules) #~(foo #$(with-imported-modules '((foo)) #~+) #+(with-imported-modules '((bar)) #~-)))) (test-equal "gexp-modules & ungexp-splicing" '((foo) (bar)) ((@@ (guix gexp) gexp-modules) #~(foo #$@(list (with-imported-modules '((foo)) #~+) (with-imported-modules '((bar)) #~-))))) (test-assert "gexp-modules deletes duplicates" ; (let ((make-file (lambda () ;; Use 'eval' to make sure we get an object that's not ;; 'eq?' nor 'equal?' due to the closures it embeds. (eval '(scheme-file "bar.scm" #~(define-module (bar))) (current-module))))) (define result ((@@ (guix gexp) gexp-modules) (with-imported-modules `(((bar) => ,(make-file)) ((bar) => ,(make-file)) (foo) (foo)) #~+))) (match result (((('bar) '=> (? scheme-file?)) ('foo)) #t)))) (test-equal "gexp-modules and literal Scheme object" '() (gexp-modules #t)) (test-assert "gexp-modules, warning" (string-match "tests/gexp.scm:[0-9]+:[0-9]+: warning: \ importing.* \\(guix config\\) from the host" (call-with-output-string (lambda (port) (parameterize ((guix-warning-port port)) (let* ((x (with-imported-modules '((guix config)) #~(+ 1 2 3))) (y #~(+ 39 #$x))) (gexp-modules y))))))) (test-assertm "gexp->derivation #:modules" (mlet* %store-monad ((build -> #~(begin (use-modules (guix build utils)) (mkdir-p (string-append #$output "/guile/guix/nix")) #t)) (drv (gexp->derivation "test-with-modules" build #:modules '((guix build utils))))) (mbegin %store-monad (built-derivations (list drv)) (let* ((p (derivation->output-path drv)) (s (stat (string-append p "/guile/guix/nix")))) (return (eq? (stat:type s) 'directory)))))) (test-assertm "gexp->derivation & with-imported-modules" ;; Same test as above, but using 'with-imported-modules'. (mlet* %store-monad ((build -> (with-imported-modules '((guix build utils)) #~(begin (use-modules (guix build utils)) (mkdir-p (string-append #$output "/guile/guix/nix")) #t))) (drv (gexp->derivation "test-with-modules" build))) (mbegin %store-monad (built-derivations (list drv)) (let* ((p (derivation->output-path drv)) (s (stat (string-append p "/guile/guix/nix")))) (return (eq? (stat:type s) 'directory)))))) (test-assertm "gexp->derivation & nested with-imported-modules" (mlet* %store-monad ((build1 -> (with-imported-modules '((guix build utils)) #~(begin (use-modules (guix build utils)) (mkdir-p (string-append #$output "/guile/guix/nix")) #t))) (build2 -> (with-imported-modules '((guix build bournish)) #~(begin (use-modules (guix build bournish) (system base compile)) #+build1 (call-with-output-file (string-append #$output "/b") (lambda (port) (write (read-and-compile (open-input-string "cd /foo") #:from %bournish-language #:to 'scheme) port)))))) (drv (gexp->derivation "test-with-modules" build2))) (mbegin %store-monad (built-derivations (list drv)) (let* ((p (derivation->output-path drv)) (s (stat (string-append p "/guile/guix/nix"))) (b (string-append p "/b"))) (return (and (eq? (stat:type s) 'directory) (equal? '(chdir "/foo") (call-with-input-file b read)))))))) (test-assertm "gexp->derivation & with-imported-module & computed module" (mlet* %store-monad ((module -> (scheme-file "x" #~(;; splice! (define-module (foo bar) #:export (the-answer)) (define the-answer 42)) #:splice? #t)) (build -> (with-imported-modules `(((foo bar) => ,module) (guix build utils)) #~(begin (use-modules (guix build utils) (foo bar)) mkdir-p (call-with-output-file #$output (lambda (port) (write the-answer port)))))) (drv (gexp->derivation "thing" build)) (out -> (derivation->output-path drv))) (mbegin %store-monad (built-derivations (list drv)) (return (= 42 (call-with-input-file out read)))))) (test-equal "gexp-extensions & ungexp" (list sed grep) ((@@ (guix gexp) gexp-extensions) #~(foo #$(with-extensions (list grep) #~+) #+(with-extensions (list sed) #~-)))) (test-equal "gexp-extensions & ungexp-splicing" (list grep sed) ((@@ (guix gexp) gexp-extensions) #~(foo #$@(list (with-extensions (list grep) #~+) (with-imported-modules '((foo)) (with-extensions (list sed) #~-)))))) (test-equal "gexp-extensions and literal Scheme object" '() ((@@ (guix gexp) gexp-extensions) #t)) (test-assertm "gexp->derivation & with-extensions" ;; Create a fake Guile extension and make sure it is accessible both to the ;; imported modules and to the derivation build script. (mlet* %store-monad ((extension -> %extension-package) (module -> (scheme-file "x" #~( ;; splice! (define-module (foo) #:use-module (hg2g) #:export (multiply)) (define (multiply x) (* the-answer x))) #:splice? #t)) (build -> (with-extensions (list extension) (with-imported-modules `((guix build utils) ((foo) => ,module)) #~(begin (use-modules (guix build utils) (hg2g) (foo)) (call-with-output-file #$output (lambda (port) (write (list the-answer (multiply 2)) port))))))) (drv (gexp->derivation "thingie" build ;; %BOOTSTRAP-GUILE is 2.0. #:effective-version "2.0")) (out -> (derivation->output-path drv))) (mbegin %store-monad (built-derivations (list drv)) (return (equal? '(42 84) (call-with-input-file out read)))))) (test-assertm "lower-gexp" (mlet* %store-monad ((extension -> %extension-package) (extension-drv (package->derivation %extension-package)) (coreutils-drv (package->derivation coreutils)) (exp -> (with-extensions (list extension) (with-imported-modules `((guix build utils)) #~(begin (use-modules (guix build utils) (hg2g)) #$coreutils:debug mkdir-p the-answer)))) (lexp (lower-gexp exp #:effective-version "2.0"))) (define (matching-input drv output) (lambda (input) (and (eq? (derivation-input-derivation input) drv) (equal? (derivation-input-sub-derivations input) (list output))))) (mbegin %store-monad (return (and (find (matching-input extension-drv "out") (lowered-gexp-inputs (pk 'lexp lexp))) (find (matching-input coreutils-drv "debug") (lowered-gexp-inputs lexp)) (member (string-append (derivation->output-path extension-drv) "/share/guile/site/2.0") (lowered-gexp-load-path lexp)) (= 2 (length (lowered-gexp-load-path lexp))) (member (string-append (derivation->output-path extension-drv) "/lib/guile/2.0/site-ccache") (lowered-gexp-load-compiled-path lexp)) (= 2 (length (lowered-gexp-load-compiled-path lexp))) (eq? (derivation-input-derivation (lowered-gexp-guile lexp)) (%guile-for-build))))))) (test-assertm "lower-gexp, raw-derivation-file" (mlet* %store-monad ((thing -> (program-file "prog" #~(display "hi!"))) (exp -> #~(list #$(raw-derivation-file thing))) (drv (lower-object thing)) (lexp (lower-gexp exp #:effective-version "2.0"))) (return (and (equal? `(list ,(derivation-file-name drv)) (lowered-gexp-sexp lexp)) (equal? (list (derivation-file-name drv)) (lowered-gexp-sources lexp)) (null? (lowered-gexp-inputs lexp)))))) (test-eq "lower-gexp, non-self-quoting input" + (guard (c ((gexp-input-error? c) (gexp-error-invalid-input c))) (run-with-store %store (lower-gexp #~(foo #$+))))) (test-equal "lower-gexp, character literal" '(#\+) (lowered-gexp-sexp (run-with-store %store (lower-gexp #~(#\+))))) (test-assertm "gexp->derivation #:references-graphs" (mlet* %store-monad ((one (text-file "one" (random-text))) (two (gexp->derivation "two" #~(symlink #$one #$output:chbouib))) (build -> (with-imported-modules '((guix build store-copy) (guix progress) (guix records) (guix sets) (guix build utils)) #~(begin (use-modules (guix build store-copy)) (with-output-to-file #$output (lambda () (write (map store-info-item (call-with-input-file "guile" read-reference-graph))))) (with-output-to-file #$output:one (lambda () (write (map store-info-item (call-with-input-file "one" read-reference-graph))))) (with-output-to-file #$output:two (lambda () (write (map store-info-item (call-with-input-file "two" read-reference-graph)))))))) (drv (gexp->derivation "ref-graphs" build #:references-graphs `(("one" ,one) ("two" ,two "chbouib") ("guile" ,%bootstrap-guile)))) (ok? (built-derivations (list drv))) (guile-drv (package->derivation %bootstrap-guile)) (bash (interned-file (search-bootstrap-binary "bash" (%current-system)) "bash" #:recursive? #t)) (g-one -> (derivation->output-path drv "one")) (g-two -> (derivation->output-path drv "two")) (g-guile -> (derivation->output-path drv))) (return (and ok? (equal? (call-with-input-file g-one read) (list one)) (lset= string=? (call-with-input-file g-two read) (list one (derivation->output-path two "chbouib"))) ;; Note: %BOOTSTRAP-GUILE depends on the bootstrap Bash. (lset= string=? (call-with-input-file g-guile read) (list (derivation->output-path guile-drv) bash)))))) (test-assertm "gexp->derivation #:references-graphs cross-compilation" ;; The objects passed in #:references-graphs implicitly refer to ;; cross-compiled derivations. Make sure this is the case. (mlet* %store-monad ((drv1 (lower-object coreutils (%current-system) #:target "i586-pc-gnu")) (drv2 (lower-object coreutils (%current-system) #:target #f)) (drv3 (gexp->derivation "three" #~(symlink #$coreutils #$output) #:target "i586-pc-gnu" #:references-graphs `(("coreutils" ,coreutils)))) (refs (references* (derivation-file-name drv3)))) (return (and (member (derivation-file-name drv1) refs) (not (member (derivation-file-name drv2) refs)))))) (test-assertm "gexp->derivation #:allowed-references" (mlet %store-monad ((drv (gexp->derivation "allowed-refs" #~(begin (mkdir #$output) (chdir #$output) (symlink #$output "self") (symlink #$%bootstrap-guile "guile")) #:allowed-references (list "out" %bootstrap-guile)))) (built-derivations (list drv)))) (test-assertm "gexp->derivation #:allowed-references, specific output" (mlet* %store-monad ((in (gexp->derivation "thing" #~(begin (mkdir #$output:ok) (mkdir #$output:not-ok)))) (drv (gexp->derivation "allowed-refs" #~(begin (pk #$in:not-ok) (mkdir #$output) (chdir #$output) (symlink #$output "self") (symlink #$in:ok "ok")) #:allowed-references (list "out" (gexp-input in "ok"))))) (built-derivations (list drv)))) (test-assert "gexp->derivation #:allowed-references, disallowed" (let ((drv (run-with-store %store (gexp->derivation "allowed-refs" #~(begin (mkdir #$output) (chdir #$output) (symlink #$%bootstrap-guile "guile")) #:allowed-references '())))) (guard (c ((store-protocol-error? c) #t)) (build-derivations %store (list drv)) #f))) (test-assertm "gexp->derivation #:disallowed-references, allowed" (mlet %store-monad ((drv (gexp->derivation "disallowed-refs" #~(begin (mkdir #$output) (chdir #$output) (symlink #$output "self") (symlink #$%bootstrap-guile "guile")) #:disallowed-references '()))) (built-derivations (list drv)))) (test-assert "gexp->derivation #:disallowed-references" (let ((drv (run-with-store %store (gexp->derivation "disallowed-refs" #~(begin (mkdir #$output) (chdir #$output) (symlink #$%bootstrap-guile "guile")) #:disallowed-references (list %bootstrap-guile))))) (guard (c ((store-protocol-error? c) #t)) (build-derivations %store (list drv)) #f))) (define shebang (string-append "#!" (derivation->output-path (%guile-for-build)) "/bin/guile --no-auto-compile")) ;; If we're going to hit the silly shebang limit (128 chars on Linux-based ;; systems), then skip the following test. (test-skip (if (> (string-length shebang) 127) 2 0)) (test-assertm "gexp->script" (mlet* %store-monad ((n -> (random (expt 2 50))) (exp -> (gexp (system* (string-append (ungexp %bootstrap-guile) "/bin/guile") "-c" (object->string '(display (expt (ungexp n) 2)))))) (drv (gexp->script "guile-thing" exp #:guile %bootstrap-guile)) (out -> (derivation->output-path drv)) (done (built-derivations (list drv)))) (let* ((pipe (open-input-pipe out)) (str (get-string-all pipe))) (return (and (zero? (close-pipe pipe)) (= (expt n 2) (string->number str))))))) (test-assert "gexp->script #:module-path" (call-with-temporary-directory (lambda (directory) (define str "Fake (guix base32) module!") (mkdir (string-append directory "/guix")) (call-with-output-file (string-append directory "/guix/base32.scm") (lambda (port) (write `(begin (define-module (guix base32)) (define-public %fake! ,str)) port))) (run-with-store %store (mlet* %store-monad ((exp -> (with-imported-modules '((guix base32)) (gexp (begin (use-modules (guix base32)) (write (list %load-path %fake!)))))) (drv (gexp->script "guile-thing" exp #:guile %bootstrap-guile #:module-path (list directory))) (out -> (derivation->output-path drv)) (done (built-derivations (list drv)))) (let* ((pipe (open-input-pipe out)) (data (read pipe))) (return (and (zero? (close-pipe pipe)) (match data ((load-path str*) (and (string=? str* str) (not (member directory load-path))))))))))))) (test-assertm "program-file" (let* ((n (random (expt 2 50))) (exp (with-imported-modules '((guix build utils)) (gexp (begin (use-modules (guix build utils)) (display (ungexp n)))))) (file (program-file "program" exp #:guile %bootstrap-guile))) (mlet* %store-monad ((drv (lower-object file)) (out -> (derivation->output-path drv))) (mbegin %store-monad (built-derivations (list drv)) (let* ((pipe (open-input-pipe out)) (str (get-string-all pipe))) (return (and (zero? (close-pipe pipe)) (= n (string->number str))))))))) (test-assert "program-file #:module-path" (call-with-temporary-directory (lambda (directory) (define text (random-text)) (call-with-output-file (string-append directory "/stupid-module.scm") (lambda (port) (write `(begin (define-module (stupid-module)) (define-public %stupid-thing ,text)) port))) (let* ((exp (with-imported-modules '((stupid-module)) (gexp (begin (use-modules (stupid-module)) (display %stupid-thing))))) (file (program-file "program" exp #:guile %bootstrap-guile #:module-path (list directory)))) (run-with-store %store (mlet* %store-monad ((drv (lower-object file)) (out -> (derivation->output-path drv))) (mbegin %store-monad (built-derivations (list drv)) (let* ((pipe (open-input-pipe out)) (str (get-string-all pipe))) (return (and (zero? (close-pipe pipe)) (string=? text str))))))))))) (test-assertm "program-file & with-extensions" (let* ((exp (with-extensions (list %extension-package) (gexp (begin (use-modules (hg2g)) (display the-answer))))) (file (program-file "program" exp #:guile %bootstrap-guile))) (mlet* %store-monad ((drv (lower-object file)) (out -> (derivation->output-path drv))) (mbegin %store-monad (built-derivations (list drv)) (let* ((pipe (open-input-pipe out)) (str (get-string-all pipe))) (return (and (zero? (close-pipe pipe)) (= 42 (string->number str))))))))) (test-assertm "program-file #:system" (let* ((exp (with-imported-modules '((guix build utils)) (gexp (begin (use-modules (guix build utils)) (display "hi!"))))) (system (if (string=? (%current-system) "x86_64-linux") "armhf-linux" "x86_64-linux")) (file (program-file "program" exp))) (mlet %store-monad ((drv (lower-object file system))) (return (and (string=? (derivation-system drv) system) (find (lambda (input) (let ((drv (pk (derivation-input-derivation input)))) (and (string=? (derivation-name drv) "module-import-compiled") (string=? (derivation-system drv) system)))) (derivation-inputs drv))))))) (test-assertm "scheme-file" (let* ((text (plain-file "foo" "Hello, world!")) (scheme (scheme-file "bar" #~(list "foo" #$text)))) (mlet* %store-monad ((drv (lower-object scheme)) (text (lower-object text)) (out -> (derivation->output-path drv))) (mbegin %store-monad (built-derivations (list drv)) (mlet %store-monad ((refs (references* out))) (return (and (equal? refs (list text)) (equal? `(list "foo" ,text) (call-with-input-file out read))))))))) (test-assertm "raw-derivation-file" (let* ((exp #~(let ((drv #$(raw-derivation-file coreutils))) (when (file-exists? drv) (symlink drv #$output))))) (mlet* %store-monad ((dep (lower-object coreutils)) (drv (gexp->derivation "drv-ref" exp)) (out -> (derivation->output-path drv))) (mbegin %store-monad (built-derivations (list drv)) (mlet %store-monad ((refs (references* out))) (return (and (member (derivation-file-name dep) (derivation-sources drv)) (not (member (derivation-file-name dep) (map derivation-input-path (derivation-inputs drv)))) (equal? (readlink out) (derivation-file-name dep)) (equal? refs (list (derivation-file-name dep)))))))))) (test-assert "text-file*" (run-with-store %store (mlet* %store-monad ((drv (package->derivation %bootstrap-guile)) (guile -> (derivation->output-path drv)) (file (text-file "bar" "This is bar.")) (text (text-file* "foo" %bootstrap-guile "/bin/guile " (gexp-input %bootstrap-guile "out") "/bin/guile " drv "/bin/guile " file)) (done (built-derivations (list text))) (out -> (derivation->output-path text)) (refs (references* out))) ;; Make sure we get the right references and the right content. (return (and (lset= string=? refs (list guile file)) (equal? (call-with-input-file out get-string-all) (string-append guile "/bin/guile " guile "/bin/guile " guile "/bin/guile " file))))) #:guile-for-build (package-derivation %store %bootstrap-guile))) (test-assertm "mixed-text-file" (mlet* %store-monad ((file -> (mixed-text-file "mixed" #:guile %bootstrap-guile "export PATH=" %bootstrap-guile "/bin")) (drv (lower-object file)) (out -> (derivation->output-path drv)) (guile-drv (package->derivation %bootstrap-guile)) (guile -> (derivation->output-path guile-drv))) (mbegin %store-monad (built-derivations (list drv)) (mlet %store-monad ((refs (references* out))) (return (and (string=? (string-append "export PATH=" guile "/bin") (call-with-input-file out get-string-all)) (equal? refs (list guile)))))))) (test-assertm "file-union" (mlet* %store-monad ((union -> (file-union "union" `(("a" ,(plain-file "a" "1")) ("b/c/d" ,(plain-file "d" "2")) ("e" ,(plain-file "e" "3"))) #:guile %bootstrap-guile)) (drv (lower-object union)) (out -> (derivation->output-path drv))) (define (contents=? file str) (string=? (call-with-input-file (string-append out "/" file) get-string-all) str)) (mbegin %store-monad (built-derivations (list drv)) (return (and (contents=? "a" "1") (contents=? "b/c/d" "2") (contents=? "e" "3")))))) (test-assert "gexp->derivation vs. %current-target-system" (let ((mval (gexp->derivation "foo" #~(begin (mkdir #$output) (foo #+gnu-make)) #:target #f))) ;; The value of %CURRENT-TARGET-SYSTEM at bind-time should have no ;; influence. (parameterize ((%current-target-system "fooooo")) (derivation? (run-with-store %store mval))))) (test-assertm "lower-object" (mlet %store-monad ((drv1 (lower-object %bootstrap-guile)) (drv2 (lower-object (package-source coreutils))) (item (lower-object (plain-file "foo" "Hello!")))) (return (and (derivation? drv1) (derivation? drv2) (store-path? item))))) (test-assertm "lower-object, computed-file" (let* ((text (plain-file "foo" "Hello!")) (exp #~(begin (mkdir #$output) (symlink #$%bootstrap-guile (string-append #$output "/guile")) (symlink #$text (string-append #$output "/text")))) (computed (computed-file "computed" exp #:guile %bootstrap-guile))) (mlet* %store-monad ((text (lower-object text)) (guile-drv (lower-object %bootstrap-guile)) (comp-drv (lower-object computed)) (comp -> (derivation->output-path comp-drv))) (mbegin %store-monad (built-derivations (list comp-drv)) (return (and (string=? (readlink (string-append comp "/guile")) (derivation->output-path guile-drv)) (string=? (readlink (string-append comp "/text")) text))))))) (test-assert "lower-object, computed-file + grafts" ;; The reference graph should refer to grafted packages when grafts are ;; enabled. See . (let* ((base (package (inherit (dummy-package "trivial")) (build-system trivial-build-system) (arguments `(#:guile ,%bootstrap-guile #:builder (mkdir %output))))) (pkg (package (inherit base) (version "1.1") (replacement (package (inherit base) (version "9.9"))))) (exp #~(begin (use-modules (ice-9 rdelim)) (let ((item (call-with-input-file "graph" read-line))) (call-with-output-file #$output (lambda (port) (display item port)))))) (computed (computed-file "computed" exp #:options `(#:references-graphs (("graph" ,pkg))) #:guile %bootstrap-guile)) (drv0 (package-derivation %store pkg #:graft? #t)) (drv1 (parameterize ((%graft? #t)) (run-with-store %store (lower-object computed))))) (build-derivations %store (list drv1)) ;; The graph obtained in COMPUTED should refer to the grafted version of ;; PKG, not to PKG itself. (string=? (call-with-input-file (derivation->output-path drv1) get-string-all) (derivation->output-path drv0)))) (test-equal "lower-object, computed-file, #:system" '("mips64el-linux") (run-with-store %store (let* ((exp #~(symlink #$coreutils #$output)) (computed (computed-file "computed" exp #:guile %bootstrap-guile))) ;; Make sure that the SYSTEM argument to 'lower-object' is honored. (mlet* %store-monad ((drv (lower-object computed "mips64el-linux")) (refs (references* (derivation-file-name drv)))) (return (delete-duplicates (filter-map (lambda (file) (and (string-suffix? ".drv" file) (let ((drv (read-derivation-from-file file))) (derivation-system drv)))) (cons (derivation-file-name drv) refs)))))))) (test-assertm "lower-object, computed-file, #:target" (let* ((target "i586-pc-gnu") (computed (computed-file "computed-cross" #~(symlink #$coreutils output) #:guile (default-guile)))) ;; When lowered to TARGET, the derivation of COMPUTED should run natively, ;; using a native Guile, but it should refer to the target COREUTILS. (mlet* %store-monad ((drv (lower-object computed (%current-system) #:target target)) (refs (references* (derivation-file-name drv))) (guile (lower-object (default-guile) (%current-system) #:target #f)) (cross (lower-object coreutils #:target target)) (native (lower-object coreutils #:target #f))) (return (and (string=? (derivation-system (pk 'drv drv)) (%current-system)) (string=? (derivation-builder drv) (string-append (derivation->output-path guile) "/bin/guile")) (not (member (derivation-file-name native) refs)) (member (derivation-file-name cross) refs)))))) (test-assertm "references-file" (let* ((exp #~(symlink #$%bootstrap-guile #$output)) (computed (computed-file "computed" exp #:guile %bootstrap-guile)) (refs (references-file computed "refs" #:guile %bootstrap-guile))) (mlet* %store-monad ((drv0 (lower-object %bootstrap-guile)) (drv1 (lower-object computed)) (drv2 (lower-object refs))) (mbegin %store-monad (built-derivations (list drv2)) (mlet %store-monad ((refs ((store-lift requisites) (list (derivation->output-path drv1))))) (return (lset= string=? (call-with-input-file (derivation->output-path drv2) read) refs))))))) (test-assertm "references-file, non-default output" (let* ((exp #~(begin (mkdir #$output) (symlink #$%bootstrap-guile #$output:extra))) (computed (computed-file "computed" exp #:guile %bootstrap-guile)) (refs1 (references-file computed #:guile %bootstrap-guile)) ;; Wrap COMPUTE in 'gexp-input' to get the "extra" output. (refs2 (references-file (gexp-input computed "extra") #:guile %bootstrap-guile))) (mlet* %store-monad ((drv0 (lower-object %bootstrap-guile)) (drv1 (lower-object computed)) (drv2 (lower-object refs2)) (drv3 (lower-object refs1))) (mbegin %store-monad (built-derivations (list drv2 drv3)) (mlet %store-monad ((refs ((store-lift requisites) (list (derivation->output-path drv1 "extra"))))) (return (and (lset= string=? (call-with-input-file (derivation->output-path drv2) read) refs) (lset= string=? (call-with-input-file (derivation->output-path drv3) read) (list (derivation->output-path drv1)))))))))) (test-assert "lower-object & gexp-input-error?" (guard (c ((gexp-input-error? c) (gexp-error-invalid-input c))) (run-with-store %store (lower-object (current-module)) #:guile-for-build (%guile-for-build)))) (test-assert "printer" (string-match "^#$" (with-output-to-string (lambda () (write (gexp (string-append (ungexp coreutils) "/bin/uname"))))))) (test-assert "printer vs. ungexp-splicing" (string-match "^#$" (with-output-to-string (lambda () ;; #~(begin #$@#~()) (write (gexp (begin (ungexp-splicing (gexp ()))))))))) (test-equal "sugar" '(gexp (foo (ungexp bar) (ungexp baz "out") (ungexp (chbouib 42)) (ungexp-splicing (list x y z)) (ungexp-native foo) (ungexp-native foo "out") (ungexp-native (chbouib 42)) (ungexp-native-splicing (list x y z)))) '#~(foo #$bar #$baz:out #$(chbouib 42) #$@(list x y z) #+foo #+foo:out #+(chbouib 42) #+@(list x y z))) (test-assertm "gexp->file, cross-compilation" (mlet* %store-monad ((target -> "aarch64-linux-gnu") (exp -> (gexp (list (ungexp coreutils)))) (xdrv (gexp->file "foo" exp #:target target)) (refs (references* (derivation-file-name xdrv))) (xcu (package->cross-derivation coreutils target)) (cu (package->derivation coreutils))) (return (and (member (derivation-file-name xcu) refs) (not (member (derivation-file-name cu) refs)))))) (test-assertm "gexp->file, cross-compilation with default target" (mlet* %store-monad ((target -> "aarch64-linux-gnu") (_ (set-current-target target)) (exp -> (gexp (list (ungexp coreutils)))) (xdrv (gexp->file "foo" exp)) (refs (references* (derivation-file-name xdrv))) (xcu (package->cross-derivation coreutils target)) (cu (package->derivation coreutils))) (return (and (member (derivation-file-name xcu) refs) (not (member (derivation-file-name cu) refs)))))) (test-assertm "gexp->script, cross-compilation" (mlet* %store-monad ((target -> "aarch64-linux-gnu") (exp -> (gexp (list (ungexp coreutils)))) (xdrv (gexp->script "foo" exp #:target target)) (refs (references* (derivation-file-name xdrv))) (xcu (package->cross-derivation coreutils target)) (cu (package->derivation coreutils))) (return (and (member (derivation-file-name xcu) refs) (not (member (derivation-file-name cu) refs)))))) (test-assertm "gexp->script, cross-compilation with default target" (mlet* %store-monad ((target -> "aarch64-linux-gnu") (_ (set-current-target target)) (exp -> (gexp (list (ungexp coreutils)))) (xdrv (gexp->script "foo" exp)) (refs (references* (derivation-file-name xdrv))) (xcu (package->cross-derivation coreutils target)) (cu (package->derivation coreutils))) (return (and (member (derivation-file-name xcu) refs) (not (member (derivation-file-name cu) refs)))))) (test-end "gexp") ;; Local Variables: ;; eval: (put 'test-assertm 'scheme-indent-function 1) ;; End: