diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/gexp.scm | 31 | ||||
| -rw-r--r-- | tests/go.scm | 132 | ||||
| -rw-r--r-- | tests/hackage.scm | 42 | ||||
| -rw-r--r-- | tests/lint.scm | 172 | ||||
| -rw-r--r-- | tests/pack.scm | 94 | ||||
| -rw-r--r-- | tests/services/configuration.scm | 12 |
6 files changed, 477 insertions, 6 deletions
diff --git a/tests/gexp.scm b/tests/gexp.scm index 64c3107ef7..709a198e1e 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> ;;; ;;; This file is part of GNU Guix. ;;; @@ -89,6 +90,36 @@ (test-begin "gexp") +(test-equal "no references" + '(display "hello gexp->approximate-sexp!") + (gexp->approximate-sexp #~(display "hello gexp->approximate-sexp!"))) + +(test-equal "unquoted gexp" + '(display "hello") + (let ((inside #~"hello")) + (gexp->approximate-sexp #~(display #$inside)))) + +(test-equal "unquoted gexp (native)" + '(display "hello") + (let ((inside #~"hello")) + (gexp->approximate-sexp #~(display #+inside)))) + +(test-equal "spliced gexp" + '(display '(fresh vegetables)) + (let ((inside #~(fresh vegetables))) + (gexp->approximate-sexp #~(display '(#$@inside))))) + +(test-equal "unspliced gexp, approximated" + ;; (*approximate*) is really an implementation detail + '(display '(*approximate*)) + (let ((inside (file-append coreutils "/bin/hello"))) + (gexp->approximate-sexp #~(display '(#$@inside))))) + +(test-equal "unquoted gexp, approximated" + '(display '(*approximate*)) + (let ((inside (file-append coreutils "/bin/hello"))) + (gexp->approximate-sexp #~(display '#$inside)))) + (test-equal "no refs" '(display "hello!") (let ((exp (gexp (display "hello!")))) diff --git a/tests/go.scm b/tests/go.scm index b088ab50d2..6749f4585f 100644 --- a/tests/go.scm +++ b/tests/go.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2021 François Joulaud <francois.joulaud@radiofrance.com> +;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; ;;; This file is part of GNU Guix. ;;; @@ -31,6 +32,9 @@ #:use-module (srfi srfi-64) #:use-module (web response)) +(define go.mod-requirements + (@@ (guix import go) go.mod-requirements)) + (define parse-go.mod (@@ (guix import go) parse-go.mod)) @@ -57,7 +61,6 @@ require ( exclude D v1.2.3 ") - (define fixture-go-mod-complete "module M @@ -96,11 +99,40 @@ replace ( ") +(define fixture-go-mod-unparseable + "module my/thing +go 1.12 // avoid feature X +require other/thing v1.0.2 +// Security issue: CVE-XXXXX +exclude old/thing v1.2.3 +new-directive another/thing yet-another/thing +replace ( + bad/thing v1.4.5 => good/thing v1.4.5 + // Unparseable + bad/thing [v1.4.5, v1.9.7] => good/thing v2.0.0 +) +") +(define fixture-go-mod-retract + "retract v0.9.1 -(define fixture-latest-for-go-check - "{\"Version\":\"v0.0.0-20201130134442-10cb98267c6c\",\"Time\":\"2020-11-30T13:44:42Z\"}") +retract ( + v1.9.2 + [v1.0.0, v1.7.9] +) +") +(define fixture-go-mod-strings + "require `example.com/\"some-repo\"` v1.9.3 +require ( + `example.com/\"another.repo\"` v1.0.0 + \"example.com/special!repo\" v9.3.1 +) +replace \"example.com/\\\"some-repo\\\"\" => `launchpad.net/some-repo` v1.9.3 +replace ( + \"example.com/\\\"another.repo\\\"\" => launchpad.net/another-repo v1.0.0 +) +") (define fixtures-go-check-test (let ((version @@ -185,7 +217,7 @@ require github.com/kr/pretty v0.2.1 (string<? (car p1) (car p2))) (test-equal name (sort expected inf?) - (sort ((@@ (guix import go) parse-go.mod) input) inf?))) + (sort (go.mod-requirements (parse-go.mod input)) inf?))) (testing-parse-mod "parse-go.mod-simple" '(("good/thing" "v1.4.5") @@ -221,6 +253,98 @@ require github.com/kr/pretty v0.2.1 ("github.com/go-check/check" "v0.0.0-20140225173054-eb6ee6f84d0a")) fixture-go-mod-complete) +(test-equal "parse-go.mod: simple" + `((module (module-path "my/thing")) + (go (version "1.12")) + (require (module-path "other/thing") (version "v1.0.2")) + (require (module-path "new/thing/v2") (version "v2.3.4")) + (exclude (module-path "old/thing") (version "v1.2.3")) + (replace (original (module-path "bad/thing") (version "v1.4.5")) + (with (module-path "good/thing") (version "v1.4.5")))) + (parse-go.mod fixture-go-mod-simple)) + +(test-equal "parse-go.mod: comments and unparseable lines" + `((module (module-path "my/thing")) + (go (version "1.12") (comment "avoid feature X")) + (require (module-path "other/thing") (version "v1.0.2")) + (comment "Security issue: CVE-XXXXX") + (exclude (module-path "old/thing") (version "v1.2.3")) + (unknown "new-directive another/thing yet-another/thing") + (replace (original (module-path "bad/thing") (version "v1.4.5")) + (with (module-path "good/thing") (version "v1.4.5"))) + (comment "Unparseable") + (unknown "bad/thing [v1.4.5, v1.9.7] => good/thing v2.0.0")) + (parse-go.mod fixture-go-mod-unparseable)) + +(test-equal "parse-go.mod: retract" + `((retract (version "v0.9.1")) + (retract (version "v1.9.2")) + (retract (range (version "v1.0.0") (version "v1.7.9")))) + (parse-go.mod fixture-go-mod-retract)) + +(test-equal "parse-go.mod: raw strings and quoted strings" + `((require (module-path "example.com/\"some-repo\"") (version "v1.9.3")) + (require (module-path "example.com/\"another.repo\"") (version "v1.0.0")) + (require (module-path "example.com/special!repo") (version "v9.3.1")) + (replace (original (module-path "example.com/\"some-repo\"")) + (with (module-path "launchpad.net/some-repo") (version "v1.9.3"))) + (replace (original (module-path "example.com/\"another.repo\"")) + (with (module-path "launchpad.net/another-repo") (version "v1.0.0")))) + (parse-go.mod fixture-go-mod-strings)) + +(test-equal "parse-go.mod: complete" + `((module (module-path "M")) + (go (version "1.13")) + (replace (original (module-path "github.com/myname/myproject/myapi")) + (with (file-path "./api"))) + (replace (original (module-path "github.com/mymname/myproject/thissdk")) + (with (file-path "../sdk"))) + (replace (original (module-path "launchpad.net/gocheck")) + (with (module-path "github.com/go-check/check") + (version "v0.0.0-20140225173054-eb6ee6f84d0a"))) + (require (module-path "github.com/user/project") + (version "v1.1.11")) + (require (module-path "github.com/user/project/sub/directory") + (version "v1.1.12")) + (require (module-path "bitbucket.org/user/project") + (version "v1.11.20")) + (require (module-path "bitbucket.org/user/project/sub/directory") + (version "v1.11.21")) + (require (module-path "launchpad.net/project") + (version "v1.1.13")) + (require (module-path "launchpad.net/project/series") + (version "v1.1.14")) + (require (module-path "launchpad.net/project/series/sub/directory") + (version "v1.1.15")) + (require (module-path "launchpad.net/~user/project/branch") + (version "v1.1.16")) + (require (module-path "launchpad.net/~user/project/branch/sub/directory") + (version "v1.1.17")) + (require (module-path "hub.jazz.net/git/user/project") + (version "v1.1.18")) + (require (module-path "hub.jazz.net/git/user/project/sub/directory") + (version "v1.1.19")) + (require (module-path "k8s.io/kubernetes/subproject") + (version "v1.1.101")) + (require (module-path "one.example.com/abitrary/repo") + (version "v1.1.111")) + (require (module-path "two.example.com/abitrary/repo") + (version "v0.0.2")) + (require (module-path "quoted.example.com/abitrary/repo") + (version "v0.0.2")) + (replace (original (module-path "two.example.com/abitrary/repo")) + (with (module-path "github.com/corp/arbitrary-repo") + (version "v0.0.2"))) + (replace (original (module-path "golang.org/x/sys")) + (with (module-path "golang.org/x/sys") + (version "v0.0.0-20190813064441-fde4db37ae7a")) + (comment "pinned to release-branch.go1.13")) + (replace (original (module-path "golang.org/x/tools")) + (with (module-path "golang.org/x/tools") + (version "v0.0.0-20190821162956-65e3620a7ae7")) + (comment "pinned to release-branch.go1.13"))) + (parse-go.mod fixture-go-mod-complete)) + ;;; End-to-end tests for (guix import go) (define (mock-http-fetch testcase) (lambda (url . rest) diff --git a/tests/hackage.scm b/tests/hackage.scm index 66a13d9881..53972fc643 100644 --- a/tests/hackage.scm +++ b/tests/hackage.scm @@ -388,4 +388,46 @@ executable cabal #t) (x (pk 'fail x #f)))) +(define test-cabal-import + "name: foo +version: 1.0.0 +homepage: http://test.org +synopsis: synopsis +description: description +license: BSD3 +common commons + build-depends: + HTTP >= 4000.2.5 && < 4000.3, + mtl >= 2.0 && < 3 + +executable cabal + import: commons +") + +(define-package-matcher match-ghc-foo-import + ('package + ('name "ghc-foo") + ('version "1.0.0") + ('source + ('origin + ('method 'url-fetch) + ('uri ('string-append + "https://hackage.haskell.org/package/foo/foo-" + 'version + ".tar.gz")) + ('sha256 + ('base32 + (? string? hash))))) + ('build-system 'haskell-build-system) + ('inputs + ('quasiquote + (("ghc-http" ('unquote 'ghc-http))))) + ('home-page "http://test.org") + ('synopsis (? string?)) + ('description (? string?)) + ('license 'license:bsd-3))) + +(test-assert "hackage->guix-package test cabal import" + (eval-test-with-cabal test-cabal-import match-ghc-foo-import)) + (test-end "hackage") diff --git a/tests/lint.scm b/tests/lint.scm index 0a8f1c6f54..dfb45ef60d 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -8,7 +8,9 @@ ;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net> ;;; Copyright © 2020 Timothy Sample <samplet@ngyro.com> +;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> +;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> ;;; ;;; This file is part of GNU Guix. ;;; @@ -38,7 +40,7 @@ #:use-module (guix lint) #:use-module (guix ui) #:use-module (guix swh) - #:use-module ((guix gexp) #:select (local-file)) + #:use-module ((guix gexp) #:select (gexp local-file gexp?)) #:use-module ((guix utils) #:select (call-with-temporary-directory)) #:use-module ((guix import hackage) #:select (%hackage-url)) #:use-module ((guix import stackage) #:select (%stackage-url)) @@ -46,6 +48,7 @@ #:use-module (gnu packages glib) #:use-module (gnu packages pkg-config) #:use-module (gnu packages python-xyz) + #:use-module ((gnu packages bash) #:select (bash bash-minimal)) #:use-module (web uri) #:use-module (web server) #:use-module (web server http) @@ -160,6 +163,13 @@ (description "This is a 'quoted' thing.")))) (check-description-style pkg)))) +(test-equal "description: leading whitespace" + "description contains leading whitespace" + (single-lint-warning-message + (let ((pkg (dummy-package "x" + (description " Whitespace.")))) + (check-description-style pkg)))) + (test-equal "description: trailing whitespace" "description contains trailing whitespace" (single-lint-warning-message @@ -370,6 +380,92 @@ ("pkgkonfig" ,pkg-config)))))) (check-input-labels pkg)))) +(test-equal "explicit #:sh argument to 'wrap-program' is acceptable" + '() + (let* ((phases + ;; Loosely based on the "catfish" package + `(modify-phases %standard-phases + (add-after 'install 'wrap + (lambda* (#:key inputs outputs #:allow-other-keys) + (define catfish (string-append (assoc-ref outputs "out") + "/bin/catfish")) + (define hsab (string-append (assoc-ref inputs "hsab") + "/bin/hsab")) + (wrap-program catfish #:sh hsab + `("PYTHONPATH" = (,"blabla"))))))) + (pkg (dummy-package "x" (arguments `(#:phases ,phases))))) + (check-wrapper-inputs pkg))) + +(test-equal + "'check-wrapper-inputs' detects 'wrap-program' without \"bash\" in inputs" + "\"bash-minimal\" should be in 'inputs' when 'wrap-program' is used" + (let* ((phases + `(modify-phases %standard-phases + (add-after 'install 'wrap + (lambda _ + (wrap-program the-binary bla-bla))))) + (pkg (dummy-package "x" (arguments `(#:phases ,phases))))) + (single-lint-warning-message (check-wrapper-inputs pkg)))) + +(test-equal + "'check-wrapper-inputs' detects 'wrap-qt-program' without \"bash\" in inputs" + "\"bash-minimal\" should be in 'inputs' when 'wrap-qt-program' is used" + (let* ((phases + `(modify-phases %standard-phases + (add-after 'install 'qtwrap + (lambda _ + (wrap-qt-program the-binary bla-bla))))) + (pkg (dummy-package "x" (arguments `(#:phases ,phases))))) + (single-lint-warning-message (check-wrapper-inputs pkg)))) + +(test-equal "\"bash\" in 'inputs' satisfies 'check-wrapper-inputs'" + '() + (let* ((phases + `(modify-phases %standard-phases + (add-after 'install 'wrap + (lambda _ + (wrap-program the-binary bla-bla))))) + (pkg (dummy-package "x" (arguments `(#:phases ,phases)) + (inputs `(("bash" ,bash)))))) + (check-wrapper-inputs pkg))) + +(test-equal "\"bash-minimal\" in 'inputs' satisfies 'check-wrapper-inputs'" + '() + (let* ((phases + `(modify-phases %standard-phases + (add-after 'install 'wrap + (lambda _ + (wrap-program THE-BINARY bla-bla))))) + (pkg (dummy-package "x" (arguments `(#:phases ,phases)) + (inputs `(("bash-minimal" ,bash-minimal)))))) + (check-wrapper-inputs pkg))) + +(test-equal "'cut' doesn't hide bad usages of 'wrap-program'" + "\"bash-minimal\" should be in 'inputs' when 'wrap-program' is used" + (let* ((phases + ;; Taken from the "straw-viewer" package + `(modify-phases %standard-phases + (add-after 'install 'wrap-program + (lambda* (#:key outputs #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (bin-dir (string-append out "/bin/")) + (site-dir (string-append out "/lib/perl5/site_perl/")) + (lib-path (getenv "PERL5LIB"))) + (for-each (cut wrap-program <> + `("PERL5LIB" ":" prefix + (,lib-path ,site-dir))) + (find-files bin-dir))))))) + (pkg (dummy-package "x" (arguments `(#:phases ,phases))))) + (single-lint-warning-message (check-wrapper-inputs pkg)))) + +(test-equal "bogus phase specifications don't crash the linter" + "invalid phase clause" + (let* ((phases + `(modify-phases %standard-phases + (add-invalid))) + (pkg (dummy-package "x" (arguments `(#:phases ,phases))))) + (single-lint-warning-message (check-wrapper-inputs pkg)))) + (test-equal "file patches: different file name -> warning" "file names of patches should start with the package name" (single-lint-warning-message @@ -758,6 +854,80 @@ (sha256 %null-sha256)))))) (check-source-unstable-tarball pkg))) +(define (package-with-phase-changes changes) + (dummy-package "x" + (arguments `(#:phases + ,(if (gexp? changes) + #~(modify-phases %standard-phases + #$@changes) + `(modify-phases %standard-phases + ,@changes)))))) + +(test-equal "optional-tests: no check phase" + '() + (let ((pkg (package-with-phase-changes '()))) + (check-optional-tests pkg))) + +(test-equal "optional-tests: check phase respects #:tests?" + '() + (let ((pkg (package-with-phase-changes + '((replace 'check + (lambda* (#:key tests? #:allow-other-keys?) + (when tests? + (invoke "./the-test-suite")))))))) + (check-optional-tests pkg))) + +(test-equal "optional-tests: check phase ignores #:tests?" + "the 'check' phase should respect #:tests?" + (let ((pkg (package-with-phase-changes + '((replace 'check + (lambda _ + (invoke "./the-test-suite"))))))) + (single-lint-warning-message + (check-optional-tests pkg)))) + +(test-equal "optional-tests: do not crash when #:phases is invalid" + "incorrect call to ‘modify-phases’" + (let ((pkg (package-with-phase-changes 'this-is-not-a-list))) + (single-lint-warning-message + (check-optional-tests pkg)))) + +(test-equal "optional-tests: allow G-exps (no warning)" + '() + (let ((pkg (package-with-phase-changes #~()))) + (check-optional-tests pkg))) + +(test-equal "optional-tests: allow G-exps (warning)" + "the 'check' phase should respect #:tests?" + (let ((pkg (package-with-phase-changes + #~((replace 'check + (lambda _ + (invoke "/the-test-suite"))))))) + (single-lint-warning-message + (check-optional-tests pkg)))) + +(test-equal "optional-tests: complicated 'check' phase" + "the 'check' phase should respect #:tests?" + (let ((pkg (package-with-phase-changes + '((replace 'check + (lambda* (#:key inputs tests? #:allow-other-keys) + (let ((something (stuff from inputs or native-inputs))) + (delete-file "dateutil/test/test_utils.py") + (invoke "pytest" "-vv")))))))) + (single-lint-warning-message + (check-optional-tests pkg)))) + +(test-equal "optional-tests: 'check' phase is not first phase" + "the 'check' phase should respect #:tests?" + (let ((pkg (package-with-phase-changes + '((add-after 'unpack + (lambda _ + (chdir "libtestcase-0.0.0"))) + (replace 'check + (lambda _ (invoke "./test-suite"))))))) + (single-lint-warning-message + (check-optional-tests pkg)))) + (test-equal "source: 200" '() (with-http-server `((200 ,%long-string)) diff --git a/tests/pack.scm b/tests/pack.scm index 8564939ee1..98bfedf21c 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -32,6 +33,7 @@ #:use-module ((gnu packages base) #:select (glibc-utf8-locales)) #:use-module (gnu packages bootstrap) #:use-module ((gnu packages compression) #:select (squashfs-tools)) + #:use-module ((gnu packages debian) #:select (dpkg)) #:use-module ((gnu packages guile) #:select (guile-sqlite3)) #:use-module ((gnu packages gnupg) #:select (guile-gcrypt)) #:use-module (srfi srfi-64)) @@ -51,11 +53,13 @@ (define %gzip-compressor ;; Compressor that uses the bootstrap 'gzip'. ((@ (guix scripts pack) compressor) "gzip" - "gz" + ".gz" #~(list #+(file-append %bootstrap-coreutils&co "/bin/gzip") "-6n"))) (define %tar-bootstrap %bootstrap-coreutils&co) +(define %ar-bootstrap %bootstrap-binutils) + (test-begin "pack") @@ -270,6 +274,94 @@ 1) (pk 'guilelink (readlink "bin")))) (mkdir #$output)))))))) + (built-derivations (list check)))) + + (unless store (test-skip 1)) + (test-assertm "deb archive with symlinks and control files" store + (mlet* %store-monad + ((guile (set-guile-for-build (default-guile))) + (profile (profile-derivation (packages->manifest + (list %bootstrap-guile)) + #:hooks '() + #:locales? #f)) + (deb (debian-archive + "deb-pack" profile + #:compressor %gzip-compressor + #:symlinks '(("/opt/gnu/bin" -> "bin")) + #:archiver %tar-bootstrap + #:extra-options + (list #:triggers-file + (plain-file "triggers" + "activate-noawait /usr/share/icons/hicolor\n") + #:postinst-file + (plain-file "postinst" + "echo running configure script\n")))) + (check + (gexp->derivation "check-deb-pack" + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (ice-9 match) + (ice-9 popen) + (ice-9 rdelim) + (ice-9 textual-ports) + (rnrs base)) + + (setenv "PATH" (string-join + (list (string-append #+%tar-bootstrap "/bin") + (string-append #+dpkg "/bin") + (string-append #+%ar-bootstrap "/bin")) + ":")) + + ;; Validate the output of 'dpkg --info'. + (let* ((port (open-pipe* OPEN_READ "dpkg" "--info" #$deb)) + (info (get-string-all port)) + (exit-val (status:exit-val (close-pipe port)))) + (assert (zero? exit-val)) + + (assert (string-contains + info + (string-append "Package: " + #+(package-name %bootstrap-guile)))) + + (assert (string-contains + info + (string-append "Version: " + #+(package-version %bootstrap-guile))))) + + ;; Sanity check .deb contents. + (invoke "ar" "-xv" #$deb) + (assert (file-exists? "debian-binary")) + (assert (file-exists? "data.tar.gz")) + (assert (file-exists? "control.tar.gz")) + + ;; Verify there are no hard links in data.tar.gz, as hard + ;; links would cause dpkg to fail unpacking the archive. + (define hard-links + (let ((port (open-pipe* OPEN_READ "tar" "-tvf" "data.tar.gz"))) + (let loop ((hard-links '())) + (match (read-line port) + ((? eof-object?) + (assert (zero? (status:exit-val (close-pipe port)))) + hard-links) + (line + (if (string-prefix? "u" line) + (loop (cons line hard-links)) + (loop hard-links))))))) + + (unless (null? hard-links) + (error "hard links found in data.tar.gz" hard-links)) + + ;; Verify the presence of the control files. + (invoke "tar" "-xf" "control.tar.gz") + (assert (file-exists? "control")) + (assert (and (file-exists? "postinst") + (= #o111 ;script is executable + (logand #o111 (stat:perms + (stat "postinst")))))) + (assert (file-exists? "triggers")) + + (mkdir #$output)))))) (built-derivations (list check))))) (test-end) diff --git a/tests/services/configuration.scm b/tests/services/configuration.scm index 85badd2da6..86a36a388d 100644 --- a/tests/services/configuration.scm +++ b/tests/services/configuration.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; ;;; This file is part of GNU Guix. ;;; @@ -82,6 +83,17 @@ (let ((config (serializable-configuration))) (serialize-configuration config serializable-configuration-fields))))) +(define (custom-prefix-serialize-integer field-name name) name) + +(define-configuration configuration-with-prefix + (port (integer 10) "The port number.") + (prefix custom-prefix-)) + +(test-assert "serialize-configuration with prefix" + (gexp? + (let ((config (configuration-with-prefix))) + (serialize-configuration config configuration-with-prefix-fields)))) + ;;; ;;; define-maybe macro. |