X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/1524851f58d8d69f6c6e1c6406cf174083bbe82d..c26fd5648c2a24dbd71f4c0851f8b5eced75e0f1:/tests/gexp.scm diff --git a/tests/gexp.scm b/tests/gexp.scm index cf88a9db80..6a42d3eb57 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,8 +23,10 @@ #:use-module (guix grafts) #:use-module (guix derivations) #:use-module (guix packages) + #:use-module (guix build-system trivial) #:use-module (guix tests) #:use-module ((guix build utils) #:select (with-directory-excursion)) + #:use-module ((guix utils) #:select (call-with-temporary-directory)) #:use-module (gnu packages) #:use-module (gnu packages base) #:use-module (gnu packages bootstrap) @@ -60,10 +62,26 @@ #:target target) #:guile-for-build (%guile-for-build))) -(define-syntax-rule (test-assertm name exp) - (test-assert name - (run-with-store %store exp - #:guile-for-build (%guile-for-build)))) +(define %extension-package + ;; Example of a package to use when testing 'with-extensions'. + (dummy-package "extension" + (build-system trivial-build-system) + (arguments + `(#:guile ,%bootstrap-guile + #:modules ((guix build utils)) + #:builder + (begin + (use-modules (guix build utils)) + (let* ((out (string-append (assoc-ref %outputs "out") + "/share/guile/site/" + (effective-version)))) + (mkdir-p out) + (call-with-output-file (string-append out "/hg2g.scm") + (lambda (port) + (write '(define-module (hg2g) + #:export (the-answer)) + port) + (write '(define the-answer 42) port))))))))) (test-begin "gexp") @@ -152,6 +170,14 @@ (let ((file (local-file "../guix/base32.scm"))) (local-file-absolute-file-name file))))) +(test-equal "local-file, non-literal relative file name" + (canonicalize-path (search-path %load-path "guix/base32.scm")) + (let ((directory (dirname (search-path %load-path + "guix/build-system/gnu.scm")))) + (with-directory-excursion directory + (let ((file (local-file (string-copy "../base32.scm")))) + (local-file-absolute-file-name file))))) + (test-assertm "local-file, #:select?" (mlet* %store-monad ((select? -> (lambda (file stat) (member (basename file) @@ -258,6 +284,44 @@ (((thing "out")) (eq? thing file)))))) +(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-assert "ungexp + ungexp-native" (let* ((exp (gexp (list (ungexp-native %bootstrap-guile) (ungexp coreutils) @@ -355,6 +419,14 @@ (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")) (gexp-native-inputs exp)) + (null? (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)) @@ -410,6 +482,24 @@ (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 @@ -432,7 +522,15 @@ (return (and (string=? (readlink (string-append out "/foo")) guile) (string=? (readlink out2) file) (equal? refs (list (dirname (dirname guile)))) - (equal? refs2 (list file)))))) + (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)) @@ -566,6 +664,9 @@ `(("graph" ,two)) #:modules '((guix build store-copy) + (guix progress) + (guix records) + (guix sets) (guix build utils)))) (ok? (built-derivations (list drv))) (out -> (derivation->output-path drv))) @@ -585,18 +686,16 @@ "guix/derivations.scm")) ("p/q" . ,(search-path %load-path "guix.scm")) ("p/z" . ,(search-path %load-path "guix/store.scm")))) - (drv (imported-files files))) + (dir (imported-files files))) (mbegin %store-monad - (built-derivations (list drv)) - (let ((dir (derivation->output-path drv))) - (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)))))) + (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!")) @@ -604,16 +703,19 @@ (files -> `(("a/b/c" . ,q-scm) ("p/q" . ,plain))) (drv (imported-files files))) + (define (file=? file1 file2) + ;; Assume deduplication is in place. + (= (stat:ino (stat file1)) + (stat:ino (stat file2)))) + (mbegin %store-monad - (built-derivations (list drv)) + (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 (string=? (readlink (string-append dir "/a/b/c")) - q-scm*) - (string=? (readlink (string-append dir "/p/q")) - plain*))))))) + (and (file=? (string-append dir "/a/b/c") q-scm*) + (file=? (string-append dir "/p/q") plain*))))))) (test-equal "gexp-modules & ungexp" '((bar) (foo)) @@ -627,6 +729,22 @@ #~(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)) @@ -691,11 +809,12 @@ (test-assertm "gexp->derivation & with-imported-module & computed module" (mlet* %store-monad - ((module -> (scheme-file "x" #~(begin + ((module -> (scheme-file "x" #~(;; splice! (define-module (foo bar) #:export (the-answer)) - (define the-answer 42)))) + (define the-answer 42)) + #:splice? #t)) (build -> (with-imported-modules `(((foo bar) => ,module) (guix build utils)) #~(begin @@ -711,27 +830,144 @@ (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 (call-with-input-file "guile" - read-reference-graph)))) + (write (map store-info-item + (call-with-input-file "guile" + read-reference-graph))))) (with-output-to-file #$output:one (lambda () - (write (call-with-input-file "one" - read-reference-graph)))) + (write (map store-info-item + (call-with-input-file "one" + read-reference-graph))))) (with-output-to-file #$output:two (lambda () - (write (call-with-input-file "two" - read-reference-graph))))))) + (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") @@ -792,7 +1028,7 @@ (chdir #$output) (symlink #$%bootstrap-guile "guile")) #:allowed-references '())))) - (guard (c ((nix-protocol-error? c) #t)) + (guard (c ((store-protocol-error? c) #t)) (build-derivations %store (list drv)) #f))) @@ -816,7 +1052,7 @@ (chdir #$output) (symlink #$%bootstrap-guile "guile")) #:disallowed-references (list %bootstrap-guile))))) - (guard (c ((nix-protocol-error? c) #t)) + (guard (c ((store-protocol-error? c) #t)) (build-derivations %store (list drv)) #f))) @@ -845,6 +1081,38 @@ (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)) @@ -862,6 +1130,69 @@ (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)))) @@ -875,6 +1206,24 @@ (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 @@ -913,6 +1262,24 @@ (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"))))) + (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 @@ -950,6 +1317,24 @@ (string=? (readlink (string-append comp "/text")) text))))))) +(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-assert "lower-object & gexp-input-error?" (guard (c ((gexp-input-error? c) (gexp-error-invalid-input c))) @@ -984,6 +1369,56 @@ '#~(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: