summaryrefslogtreecommitdiff
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/boot-parameters.scm2
-rw-r--r--tests/channels.scm47
-rw-r--r--tests/egg.scm132
-rw-r--r--tests/gexp.scm31
-rw-r--r--tests/git.scm28
-rw-r--r--tests/gnu-maintenance.scm3
-rw-r--r--tests/go.scm142
-rw-r--r--tests/grafts.scm83
-rw-r--r--tests/graph.scm21
-rw-r--r--tests/guix-package.sh2
-rw-r--r--tests/guix-system.sh14
-rw-r--r--tests/hackage.scm51
-rw-r--r--tests/import-git.scm245
-rw-r--r--tests/import-utils.scm28
-rw-r--r--tests/inferior.scm26
-rw-r--r--tests/lint.scm267
-rw-r--r--tests/minetest.scm382
-rw-r--r--tests/opam.scm32
-rw-r--r--tests/pack.scm94
-rw-r--r--tests/packages.scm11
-rw-r--r--tests/profiles.scm57
-rw-r--r--tests/publish.scm32
-rw-r--r--tests/pypi.scm106
-rw-r--r--tests/records.scm56
-rw-r--r--tests/services/configuration.scm120
-rw-r--r--tests/services/telephony.scm446
-rw-r--r--tests/snix.scm73
-rw-r--r--tests/store.scm72
-rw-r--r--tests/system.scm4
-rw-r--r--tests/transformations.scm51
30 files changed, 2478 insertions, 180 deletions
diff --git a/tests/boot-parameters.scm b/tests/boot-parameters.scm
index 3deae564c4..b2799d0596 100644
--- a/tests/boot-parameters.scm
+++ b/tests/boot-parameters.scm
@@ -81,7 +81,7 @@
(bootloader (bootloader-configuration
(bootloader grub-bootloader)
- (target "/dev/sda")))
+ (targets '("/dev/sda"))))
(file-systems (cons* (file-system
(device %default-root-device)
(mount-point %root-path)
diff --git a/tests/channels.scm b/tests/channels.scm
index 0264369d9e..3e82315b0c 100644
--- a/tests/channels.scm
+++ b/tests/channels.scm
@@ -408,6 +408,53 @@
'(#f "tag-for-first-news-entry")))))))
(unless (which (git-command)) (test-skip 1))
+(test-assert "channel-news, annotated tag"
+ (with-temporary-git-repository directory
+ `((add ".guix-channel"
+ ,(object->string
+ '(channel (version 0)
+ (news-file "news.scm"))))
+ (add "src/a.txt" "A")
+ (commit "first commit")
+ (tag "tag-for-first-news-entry"
+ "This is an annotated tag.")
+ (add "news.scm"
+ ,(lambda (repository)
+ (let ((previous
+ (reference-name->oid repository "HEAD")))
+ (object->string
+ `(channel-news
+ (version 0)
+ (entry (tag "tag-for-first-news-entry")
+ (title (en "New file!"))
+ (body (en "Yeah, a.txt."))))))))
+ (commit "second commit"))
+ (with-repository directory repository
+ (define (find-commit* message)
+ (oid->string (commit-id (find-commit repository message))))
+
+ (let ((channel (channel (url (string-append "file://" directory))
+ (name 'foo)))
+ (commit1 (find-commit* "first commit"))
+ (commit2 (find-commit* "second commit")))
+ (and (null? (channel-news-for-commit channel commit1))
+ (lset= equal?
+ (map channel-news-entry-title
+ (channel-news-for-commit channel commit2))
+ '((("en" . "New file!"))))
+ (lset= string=?
+ (map channel-news-entry-tag
+ (channel-news-for-commit channel commit2))
+ (list "tag-for-first-news-entry"))
+ ;; This is an annotated tag, but 'channel-news-entry-commit'
+ ;; should give us the commit ID, not the ID of the annotated tag
+ ;; object.
+ (lset= string=?
+ (map channel-news-entry-commit
+ (channel-news-for-commit channel commit2))
+ (list commit1)))))))
+
+(unless (which (git-command)) (test-skip 1))
(test-assert "latest-channel-instances, missing introduction for 'guix'"
(with-temporary-git-repository directory
'((add "a.txt" "A")
diff --git a/tests/egg.scm b/tests/egg.scm
new file mode 100644
index 0000000000..0884d8d429
--- /dev/null
+++ b/tests/egg.scm
@@ -0,0 +1,132 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
+;;;
+;;; 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-eggs)
+ #:use-module (guix import egg)
+ #:use-module (guix gexp)
+ #:use-module (guix base32)
+ #:use-module (gcrypt hash)
+ #:use-module (guix tests)
+ #:use-module ((guix build syscalls) #:select (mkdtemp!))
+ #:use-module ((guix build utils) #:select (delete-file-recursively mkdir-p which))
+ #:use-module ((guix utils) #:select (call-with-temporary-output-file))
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-64)
+ #:use-module (web uri)
+ #:use-module (ice-9 match))
+
+(define test-egg-1
+ '((synopsis "Example egg")
+ (license "GPL-3/MIT")
+ (version "1.0.0")
+ (test-dependencies test srfi-1)
+ (foreign-dependencies libgit2)
+ (build-dependencies begin-syntax)
+ (dependencies datatype)
+ (author "John Doe")))
+
+(define test-egg-2
+ '((synopsis "Example egg")
+ (license "GPL-3+")
+ (version "0.3")
+ (test-dependencies test)
+ (foreign-dependencies libgit2)
+ (build-dependencies begin-syntax)
+ (dependencies datatype)
+ (author "Alice Bobson")))
+
+(define test-egg-1-file "/tmp/guix-egg-1")
+(define test-egg-2-file "/tmp/guix-egg-2")
+
+(test-begin "egg")
+
+(test-equal "guix-package->egg-name"
+ "bar"
+ (guix-package->egg-name
+ (dummy-package "dummy"
+ (name "chicken-bar"))))
+
+;; Copied from tests/hackage.scm
+(define-syntax-rule (define-package-matcher name pattern)
+ (define* (name obj)
+ (match obj
+ (pattern #t)
+ (x (pk 'fail x #f)))))
+
+(define (eval-test-with-egg-file egg-name egg-test egg-file matcher)
+ (call-with-output-file egg-file
+ (lambda (port)
+ (write egg-test port)))
+ (matcher (egg->guix-package egg-name
+ #:file egg-file
+ #:source (plain-file
+ (string-append egg-name "-egg")
+ "content"))))
+
+(define-package-matcher match-chicken-foo
+ ('package
+ ('name "chicken-foo")
+ ('version "1.0.0")
+ ('source (? file-like? source))
+ ('build-system 'chicken-build-system)
+ ('arguments ('quasiquote ('#:egg-name "foo")))
+ ('native-inputs
+ ('quasiquote
+ (("chicken-test" ('unquote chicken-test))
+ ("chicken-srfi-1" ('unquote chicken-srfi-1))
+ ("chicken-begin-syntax" ('unquote chicken-begin-syntax)))))
+ ('inputs
+ ('quasiquote
+ (("libgit2" ('unquote libgit2)))))
+ ('propagated-inputs
+ ('quasiquote
+ (("chicken-datatype" ('unquote chicken-datatype)))))
+ ('home-page "https://wiki.call-cc.org/egg/foo")
+ ('synopsis "Example egg")
+ ('description #f)
+ ('license '(list license:gpl3 license:expat))))
+
+(define-package-matcher match-chicken-bar
+ ('package
+ ('name "chicken-bar")
+ ('version "0.3")
+ ('source (? file-like? source))
+ ('build-system 'chicken-build-system)
+ ('arguments ('quasiquote ('#:egg-name "bar")))
+ ('native-inputs
+ ('quasiquote
+ (("chicken-test" ('unquote chicken-test))
+ ("chicken-begin-syntax" ('unquote chicken-begin-syntax)))))
+ ('inputs
+ ('quasiquote
+ (("libgit2" ('unquote libgit2)))))
+ ('propagated-inputs
+ ('quasiquote
+ (("chicken-datatype" ('unquote chicken-datatype)))))
+ ('home-page "https://wiki.call-cc.org/egg/bar")
+ ('synopsis "Example egg")
+ ('description #f)
+ ('license 'license:gpl3+)))
+
+(test-assert "egg->guix-package local file, multiple licenses"
+ (eval-test-with-egg-file "foo" test-egg-1 test-egg-1-file match-chicken-foo))
+
+(test-assert "egg->guix-package local file, single license"
+ (eval-test-with-egg-file "bar" test-egg-2 test-egg-2-file match-chicken-bar))
+
+(test-end "egg")
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 834e78b9a0..39a47d4e8c 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/git.scm b/tests/git.scm
index aa4f03ca62..d0646bbc85 100644
--- a/tests/git.scm
+++ b/tests/git.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz
;;;
;;; This file is part of GNU Guix.
;;;
@@ -161,4 +162,31 @@
(commit-relation master1 merge)
(commit-relation merge master1))))))
+(unless (which (git-command)) (test-skip 1))
+(test-equal "remote-refs"
+ '("refs/heads/develop" "refs/heads/master"
+ "refs/tags/v1.0" "refs/tags/v1.1")
+ (with-temporary-git-repository directory
+ '((add "a.txt" "A")
+ (commit "First commit")
+ (tag "v1.0" "release-1.0")
+ (branch "develop")
+ (checkout "develop")
+ (add "b.txt" "B")
+ (commit "Second commit")
+ (tag "v1.1" "release-1.1"))
+ (remote-refs directory)))
+
+(unless (which (git-command)) (test-skip 1))
+(test-equal "remote-refs: only tags"
+ '("refs/tags/v1.0" "refs/tags/v1.1")
+ (with-temporary-git-repository directory
+ '((add "a.txt" "A")
+ (commit "First commit")
+ (tag "v1.0" "Release 1.0")
+ (add "b.txt" "B")
+ (commit "Second commit")
+ (tag "v1.1" "Release 1.1"))
+ (remote-refs directory #:tags? #t)))
+
(test-end "git")
diff --git a/tests/gnu-maintenance.scm b/tests/gnu-maintenance.scm
index 837b80063a..c04d8ba733 100644
--- a/tests/gnu-maintenance.scm
+++ b/tests/gnu-maintenance.scm
@@ -34,7 +34,8 @@
("mediainfo" "mediainfo_20.09.tar.xz")
("exiv2" "exiv2-0.27.3-Source.tar.gz")
("mpg321" "mpg321_0.3.2.orig.tar.gz")
- ("bvi" "bvi-1.4.1.src.tar.gz")))
+ ("bvi" "bvi-1.4.1.src.tar.gz")
+ ("hostscope" "hostscope-V2.1.tgz")))
(every (lambda (project+file)
(not (apply release-file? project+file)))
'(("guile" "guile-www-1.1.1.tar.gz")
diff --git a/tests/go.scm b/tests/go.scm
index e5780e68b0..a70a0ddbf5 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-unparsable
+ "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
@@ -158,15 +190,11 @@ require github.com/kr/pretty v0.2.1
"v1.0.2"
(go-version->git-ref "v1.0.2"))
-(test-equal "go-version omited 'v' character"
- "v1.0.2"
- (go-version->git-ref "v1.0.2"))
-
-(test-equal "go-version with embeded git-ref"
+(test-equal "go-version with embedded git-ref"
"65e3620a7ae7"
(go-version->git-ref "v0.0.0-20190821162956-65e3620a7ae7"))
-(test-equal "go-version with complex embeded git-ref"
+(test-equal "go-version with complex embedded git-ref"
"daa7c04131f5"
(go-version->git-ref "v1.2.4-0.20191109021931-daa7c04131f5"))
@@ -189,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")
@@ -225,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 unparsable 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-unparsable))
+
+(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)
@@ -290,6 +410,6 @@ package.")
(nix-base32-string->bytevector
"0sjjj9z1dhilhpc8pq4154czrb79z9cm044jvn75kxcjv6v5l2m5")
#f)))
- (go-module->guix-package "github.com/go-check/check")))))))
+ (go-module->guix-package* "github.com/go-check/check")))))))
(test-end "go")
diff --git a/tests/grafts.scm b/tests/grafts.scm
index a12c6a5911..7e1959e4a7 100644
--- a/tests/grafts.scm
+++ b/tests/grafts.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2021 Mark H Weaver <mhw@netris.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -468,4 +469,86 @@
replacement
"/gnu/store")))))
+(define (insert-nuls char-size str)
+ (string-join (map string (string->list str))
+ (make-string (- char-size 1) #\nul)))
+
+(define (nuls-to-underscores s)
+ (string-replace-substring s "\0" "_"))
+
+(define (annotate-buffer-boundary s)
+ (string-append (string-take s buffer-size)
+ "|"
+ (string-drop s buffer-size)))
+
+(define (abbreviate-leading-fill s)
+ (let ((s* (string-trim s #\=)))
+ (format #f "[~a =s]~a"
+ (- (string-length s)
+ (string-length s*))
+ s*)))
+
+(define (prettify-for-display s)
+ (abbreviate-leading-fill
+ (annotate-buffer-boundary
+ (nuls-to-underscores s))))
+
+(define (two-sample-refs-with-gap char-size1 char-size2 gap offset
+ char1 name1 char2 name2)
+ (string-append
+ (make-string (- buffer-size offset) #\=)
+ (insert-nuls char-size1
+ (string-append "/gnu/store/" (make-string 32 char1) name1))
+ gap
+ (insert-nuls char-size2
+ (string-append "/gnu/store/" (make-string 32 char2) name2))
+ (list->string (map integer->char (iota 77 33)))))
+
+(define (sample-map-entry old-char new-char new-name)
+ (cons (make-string 32 old-char)
+ (string->utf8 (string-append (make-string 32 new-char)
+ new-name))))
+
+(define (test-two-refs-with-gap char-size1 char-size2 gap offset)
+ (test-equal
+ (format #f "test-two-refs-with-gap, char-sizes ~a ~a, gap ~s, offset ~a"
+ char-size1 char-size2 gap offset)
+ (prettify-for-display
+ (two-sample-refs-with-gap char-size1 char-size2 gap offset
+ #\6 "-BlahBlaH"
+ #\8"-SoMeTHiNG"))
+ (prettify-for-display
+ (let* ((content (two-sample-refs-with-gap char-size1 char-size2 gap offset
+ #\5 "-blahblah"
+ #\7 "-something"))
+ (replacement (alist->vhash
+ (list (sample-map-entry #\5 #\6 "-BlahBlaH")
+ (sample-map-entry #\7 #\8 "-SoMeTHiNG")))))
+ (call-with-output-string
+ (lambda (output)
+ ((@@ (guix build graft) replace-store-references)
+ (open-input-string content) output
+ replacement
+ "/gnu/store")))))))
+
+(for-each (lambda (char-size1)
+ (for-each (lambda (char-size2)
+ (for-each (lambda (gap)
+ (for-each (lambda (offset)
+ (test-two-refs-with-gap char-size1
+ char-size2
+ gap
+ offset))
+ ;; offsets to test
+ (map (lambda (i)
+ (+ i (* 40 char-size1)))
+ (iota 30))))
+ ;; gaps
+ '("" "-" " " "a")))
+ ;; char-size2 values to test
+ '(1 2)))
+ ;; char-size1 values to test
+ '(1 2 4))
+
+
(test-end)
diff --git a/tests/graph.scm b/tests/graph.scm
index e374dad1a5..fadac265f9 100644
--- a/tests/graph.scm
+++ b/tests/graph.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -94,6 +94,25 @@ edges."
(list p3 p3 p2)
(list p2 p1 p1))))))))
+(test-assert "package DAG, limited depth"
+ (let-values (((backend nodes+edges) (make-recording-backend)))
+ (let* ((p1 (dummy-package "p1"))
+ (p2 (dummy-package "p2" (inputs `(("p1" ,p1)))))
+ (p3 (dummy-package "p3" (inputs `(("p1" ,p1)))))
+ (p4 (dummy-package "p4" (inputs `(("p2" ,p2) ("p3" ,p3))))))
+ (run-with-store %store
+ (export-graph (list p4) 'port
+ #:max-depth 1
+ #:node-type %package-node-type
+ #:backend backend))
+ ;; We should see nothing more than these 3 packages.
+ (let-values (((nodes edges) (nodes+edges)))
+ (and (equal? nodes (map package->tuple (list p4 p2 p3)))
+ (equal? edges
+ (map edge->tuple
+ (list p4 p4)
+ (list p2 p3))))))))
+
(test-assert "reverse package DAG"
(let-values (((backend nodes+edges) (make-recording-backend)))
(run-with-store %store
diff --git a/tests/guix-package.sh b/tests/guix-package.sh
index 39e2b514c3..92ab565c5b 100644
--- a/tests/guix-package.sh
+++ b/tests/guix-package.sh
@@ -459,7 +459,7 @@ if guix package --bootstrap -n -m "$module_dir/manifest.scm" \
then false
else
cat "$module_dir/stderr"
- grep "manifest.scm:[1-3]:.*wonderful-package.*: unbound variable" \
+ grep "manifest.scm:[1-4]:.*wonderful-package.*: unbound variable" \
"$module_dir/stderr"
fi
diff --git a/tests/guix-system.sh b/tests/guix-system.sh
index 238c8929a8..6aab1f380a 100644
--- a/tests/guix-system.sh
+++ b/tests/guix-system.sh
@@ -51,6 +51,7 @@ then
# This must not succeed.
exit 1
else
+ cat "$errorfile"
grep "$tmpfile:2:3:.*missing.* initializers" "$errorfile"
fi
@@ -66,7 +67,12 @@ then
# This must not succeed.
exit 1
else
- grep "$tmpfile:4:1: missing closing paren" "$errorfile"
+ cat "$errorfile"
+
+ # Guile 3.0.6 gets line/column numbers for 'read-error' wrong
+ # (zero-indexed): <https://bugs.gnu.org/48089>.
+ grep "$tmpfile:4:1: missing closing paren" "$errorfile" || \
+ grep "$tmpfile:3:0: missing closing paren" "$errorfile"
fi
@@ -109,7 +115,7 @@ cat > "$tmpfile" <<EOF
(timezone "Europe/Paris") ; 6
(locale "en_US.UTF-8") ; 7
- (bootloader (GRUB-config (target "/dev/sdX"))) ; 9
+ (bootloader (GRUB-config (targets (list "/dev/sdX")))) ; 9
(file-systems (cons (file-system
(device (file-system-label "root"))
(mount-point "/")
@@ -162,7 +168,7 @@ OS_BASE='
(bootloader (bootloader-configuration
(bootloader grub-bootloader)
- (target "/dev/sdX")))
+ (targets (list "/dev/sdX"))))
(file-systems (cons (file-system
(device (file-system-label "root"))
(mount-point "/")
@@ -235,7 +241,7 @@ make_user_config ()
(bootloader (bootloader-configuration
(bootloader grub-bootloader)
- (target "/dev/sdX")))
+ (targets (list "/dev/sdX"))))
(file-systems (cons (file-system
(device (file-system-label "root"))
(mount-point "/")
diff --git a/tests/hackage.scm b/tests/hackage.scm
index 77e333cbfc..aca807027c 100644
--- a/tests/hackage.scm
+++ b/tests/hackage.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
;;; Copyright © 2019 Robert Vollmert <rob@vllmrt.net>
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -183,7 +184,7 @@ library
('home-page "http://test.org")
('synopsis (? string?))
('description (? string?))
- ('license 'bsd-3)))
+ ('license 'license:bsd-3)))
(define* (eval-test-with-cabal test-cabal matcher #:key (cabal-environment '()))
(define port (open-input-string test-cabal))
@@ -232,7 +233,7 @@ library
('home-page "http://test.org")
('synopsis (? string?))
('description (? string?))
- ('license 'bsd-3)))
+ ('license 'license:bsd-3)))
(test-assert "hackage->guix-package test 6"
(eval-test-with-cabal test-cabal-6 match-ghc-foo-6))
@@ -317,8 +318,6 @@ executable cabal
mtl >= 2.0 && < 3
")
-;; Fails: https://debbugs.gnu.org/cgi/bugreport.cgi?bug=25138
-(test-expect-fail 1)
(test-assert "hackage->guix-package test flag executable"
(eval-test-with-cabal test-cabal-flag-executable match-ghc-foo))
@@ -362,7 +361,7 @@ executable cabal
('home-page "http://test.org")
('synopsis (? string?))
('description (? string?))
- ('license 'bsd-3)))
+ ('license 'license:bsd-3)))
(test-assert "hackage->guix-package test cabal revision"
(eval-test-with-cabal test-cabal-revision match-ghc-foo-revision))
@@ -387,4 +386,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/import-git.scm b/tests/import-git.scm
new file mode 100644
index 0000000000..f1bce154bb
--- /dev/null
+++ b/tests/import-git.scm
@@ -0,0 +1,245 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz
+;;;
+;;; 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-import-git)
+ #:use-module (git)
+ #:use-module (guix git)
+ #:use-module (guix tests)
+ #:use-module (guix packages)
+ #:use-module (guix import git)
+ #:use-module (guix git-download)
+ #:use-module (guix tests git)
+ #:use-module (guix build utils)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-64))
+
+;; Test the (guix import git) tools.
+
+(test-begin "git")
+
+(define* (make-package directory version #:optional (properties '()))
+ (dummy-package "test-package"
+ (version version)
+ (properties properties)
+ (source
+ (origin
+ (method git-fetch)
+ (uri (git-reference
+ (url (string-append "file://" directory))
+ (commit version)))
+ (sha256
+ (base32
+ "0000000000000000000000000000000000000000000000000000"))))))
+
+(unless (which (git-command)) (test-skip 1))
+(test-equal "latest-git-tag-version: no custom prefix, suffix, and delimiter"
+ "1.0.1"
+ (with-temporary-git-repository directory
+ '((add "a.txt" "A")
+ (commit "First commit")
+ (tag "1.0.1" "Release 1.0.1"))
+ (let ((package (make-package directory "1.0.0")))
+ (latest-git-tag-version package))))
+
+(unless (which (git-command)) (test-skip 1))
+(test-equal "latest-git-tag-version: custom prefix, no suffix and delimiter"
+ "1.0.1"
+ (with-temporary-git-repository directory
+ '((add "a.txt" "A")
+ (commit "First commit")
+ (tag "prefix-1.0.1" "Release 1.0.1"))
+ (let ((package (make-package directory "1.0.0"
+ '((release-tag-prefix . "prefix-")))))
+ (latest-git-tag-version package))))
+
+(unless (which (git-command)) (test-skip 1))
+(test-equal "latest-git-tag-version: custom suffix, no prefix and delimiter"
+ "1.0.1"
+ (with-temporary-git-repository directory
+ '((add "a.txt" "A")
+ (commit "First commit")
+ (tag "1.0.1-suffix-123" "Release 1.0.1"))
+ (let ((package (make-package directory "1.0.0"
+ '((release-tag-suffix . "-suffix-[0-9]*")))))
+ (latest-git-tag-version package))))
+
+(unless (which (git-command)) (test-skip 1))
+(test-equal "latest-git-tag-version: custom delimiter, no prefix and suffix"
+ "2021.09.07"
+ (with-temporary-git-repository directory
+ '((add "a.txt" "A")
+ (commit "First commit")
+ (tag "2021-09-07" "Release 2021-09-07"))
+ (let ((package (make-package directory "2021-09-06"
+ '((release-tag-version-delimiter . "-")))))
+ (latest-git-tag-version package))))
+
+(unless (which (git-command)) (test-skip 1))
+(test-equal "latest-git-tag-version: empty delimiter, no prefix and suffix"
+ "20210907"
+ (with-temporary-git-repository directory
+ '((add "a.txt" "A")
+ (commit "First commit")
+ (tag "20210907" "Release 20210907"))
+ (let ((package (make-package directory "20210906"
+ '((release-tag-version-delimiter . "")))))
+ (latest-git-tag-version package))))
+
+(unless (which (git-command)) (test-skip 1))
+(test-equal "latest-git-tag-version: custom prefix and suffix, no delimiter"
+ "2.0.0"
+ (with-temporary-git-repository directory
+ '((add "a.txt" "A")
+ (commit "First commit")
+ (tag "Release-2.0.0suffix-1" "Release 2.0.0"))
+ (let ((package (make-package directory "1.0.0"
+ '((release-tag-prefix . "Release-")
+ (release-tag-suffix . "suffix-[0-9]")))))
+ (latest-git-tag-version package))))
+
+(unless (which (git-command)) (test-skip 1))
+(test-equal "latest-git-tag-version: custom prefix, suffix, and delimiter"
+ "2.0.0"
+ (with-temporary-git-repository directory
+ '((add "a.txt" "A")
+ (commit "First commit")
+ (tag "Release-2_0_0suffix-1" "Release 2.0.0"))
+ (let ((package (make-package directory "1.0.0"
+ '((release-tag-prefix . "Release-")
+ (release-tag-suffix . "suffix-[0-9]")
+ (release-tag-version-delimiter . "_")))))
+ (latest-git-tag-version package))))
+
+(unless (which (git-command)) (test-skip 1))
+(test-equal "latest-git-tag-version: only pre-releases available"
+ #f
+ (with-temporary-git-repository directory
+ '((add "a.txt" "A")
+ (commit "First commit")
+ (tag "2.0.0-rc1" "Release candidate for 2.0.0"))
+ (let ((package (make-package directory "1.0.0")))
+ (latest-git-tag-version package))))
+
+(unless (which (git-command)) (test-skip 1))
+(test-equal "latest-git-tag-version: accept pre-releases"
+ "2.0.0-rc1"
+ (with-temporary-git-repository directory
+ '((add "a.txt" "A")
+ (commit "First commit")
+ (tag "2.0.0-rc1" "Release candidate for 2.0.0"))
+ (let ((package (make-package directory "1.0.0"
+ '((accept-pre-releases? . #t)))))
+ (latest-git-tag-version package))))
+
+(unless (which (git-command)) (test-skip 1))
+(test-equal "latest-git-tag-version: accept pre-releases, and custom prefix"
+ "2.0.0-rc1"
+ (with-temporary-git-repository directory
+ '((add "a.txt" "A")
+ (commit "First commit")
+ (tag "version-2.0.0-rc1" "Release candidate for 2.0.0"))
+ (let ((package (make-package directory "1.0.0"
+ '((accept-pre-releases? . #t)
+ (release-tag-prefix . "version-")))))
+ (latest-git-tag-version package))))
+
+(unless (which (git-command)) (test-skip 1))
+(test-equal "latest-git-tag-version: accept pre-releases, and custom suffix"
+ "2.0.0-rc1"
+ (with-temporary-git-repository directory
+ '((add "a.txt" "A")
+ (commit "First commit")
+ (tag "2.0.0-rc1-suffix" "Release candidate for 2.0.0"))
+ (let ((package (make-package directory "1.0.0"
+ '((accept-pre-releases? . #t)
+ (release-tag-suffix . "-suffix")))))
+ (latest-git-tag-version package))))
+
+(unless (which (git-command)) (test-skip 1))
+(test-equal "latest-git-tag-version: accept pre-releases, delimiter conflicts with pre-release part"
+ "2.0.0_alpha"
+ (with-temporary-git-repository directory
+ '((add "a.txt" "A")
+ (commit "First commit")
+ (tag "2_0_0_alpha" "Alpha release for 2.0.0"))
+ (let ((package (make-package directory "1.0.0"
+ '((accept-pre-releases? . #t)
+ (release-tag-version-delimiter . "_")))))
+ (latest-git-tag-version package))))
+
+(unless (which (git-command)) (test-skip 1))
+(test-equal "latest-git-tag-version: accept pre-releases, and custom suffix and prefix"
+ "2.0.0-alpha"
+ (with-temporary-git-repository directory
+ '((add "a.txt" "A")
+ (commit "First commit")
+ (tag "prefix123-2.0.0-alpha-suffix" "Alpha release for 2.0.0"))
+ (let ((package (make-package directory "1.0.0"
+ '((accept-pre-releases? . #t)
+ (release-tag-prefix . "prefix[0-9]{3}-")
+ (release-tag-suffix . "-suffix")))))
+ (latest-git-tag-version package))))
+
+(unless (which (git-command)) (test-skip 1))
+(test-equal "latest-git-tag-version: accept pre-releases, and custom suffix, prefix, and delimiter"
+ "2.0.0-alpha"
+ (with-temporary-git-repository directory
+ '((add "a.txt" "A")
+ (commit "First commit")
+ (tag "prefix123-2-0-0-alpha-suffix" "Alpha release for 2.0.0"))
+ (let ((package (make-package directory "1.0.0"
+ '((accept-pre-releases? . #t)
+ (release-tag-prefix . "prefix[0-9]{3}-")
+ (release-tag-suffix . "-suffix")
+ (release-tag-version-delimiter . "-")))))
+ (latest-git-tag-version package))))
+
+(unless (which (git-command)) (test-skip 1))
+(test-equal "latest-git-tag-version: accept pre-releases, no delimiter, and custom suffix, prefix"
+ "2alpha"
+ (with-temporary-git-repository directory
+ '((add "a.txt" "A")
+ (commit "First commit")
+ (tag "prefix123-2alpha-suffix" "Alpha release for version 2"))
+ (let ((package (make-package directory "1.0.0"
+ '((accept-pre-releases? . #t)
+ (release-tag-prefix . "prefix[0-9]{3}-")
+ (release-tag-suffix . "-suffix")
+ (release-tag-version-delimiter . "")))))
+ (latest-git-tag-version package))))
+
+(unless (which (git-command)) (test-skip 1))
+(test-equal "latest-git-tag-version: no tags found"
+ #f
+ (with-temporary-git-repository directory
+ '((add "a.txt" "A")
+ (commit "First commit"))
+ (let ((package (make-package directory "1.0.0")))
+ (latest-git-tag-version package))))
+
+(unless (which (git-command)) (test-skip 1))
+(test-equal "latest-git-tag-version: no valid tags found"
+ #f
+ (with-temporary-git-repository directory
+ '((add "a.txt" "A")
+ (commit "First commit")
+ (tag "Test" "Test tag"))
+ (let ((package (make-package directory "1.0.0")))
+ (latest-git-tag-version package))))
+
+(test-end "git")
diff --git a/tests/import-utils.scm b/tests/import-utils.scm
index 874816442e..7c6c782917 100644
--- a/tests/import-utils.scm
+++ b/tests/import-utils.scm
@@ -2,6 +2,7 @@
;;; Copyright © 2015, 2017 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com>
;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net>
+;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -64,6 +65,33 @@
'())))
#:guix-name identity))
+(test-equal "recursive-import: skip false packages (toplevel)"
+ '()
+ (recursive-import "foo"
+ #:repo 'repo
+ #:repo->guix-package
+ (match-lambda*
+ (("foo" #:version #f #:repo 'repo)
+ (values #f '())))
+ #:guix-name identity))
+
+(test-equal "recursive-import: skip false packages (dependency)"
+ '((package
+ (name "foo")
+ (inputs `(("bar" ,bar)))))
+ (recursive-import "foo"
+ #:repo 'repo
+ #:repo->guix-package
+ (match-lambda*
+ (("foo" #:version #f #:repo 'repo)
+ (values '(package
+ (name "foo")
+ (inputs `(("bar" ,bar))))
+ '("bar")))
+ (("bar" #:version #f #:repo 'repo)
+ (values #f '())))
+ #:guix-name identity))
+
(test-assert "alist->package with simple source"
(let* ((meta '(("name" . "hello")
("version" . "2.10")
diff --git a/tests/inferior.scm b/tests/inferior.scm
index 7c3d730d0c..9992077cb2 100644
--- a/tests/inferior.scm
+++ b/tests/inferior.scm
@@ -26,6 +26,7 @@
#:use-module (gnu packages)
#:use-module (gnu packages bootstrap)
#:use-module (gnu packages guile)
+ #:use-module (gnu packages sqlite)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-64)
@@ -173,9 +174,9 @@
,(package-version package)
,(package-location package))
,@rest)))))
- (list (map ->list (package-inputs guile-2.2))
- (map ->list (package-native-inputs guile-2.2))
- (map ->list (package-propagated-inputs guile-2.2))))
+ (list (map ->list (package-inputs guile-3.0-latest))
+ (map ->list (package-native-inputs guile-3.0-latest))
+ (map ->list (package-propagated-inputs guile-3.0-latest))))
(let* ((inferior (open-inferior %top-builddir
#:command "scripts/guix"))
(guile (first (lookup-inferior-packages inferior "guile")))
@@ -260,6 +261,25 @@
(list (inferior-package-derivation %store guile "x86_64-linux")
(inferior-package-derivation %store guile "armhf-linux")))))
+(unless (package-replacement sqlite)
+ (test-skip 1))
+
+(test-equal "inferior-package-replacement"
+ (package-derivation %store
+ (package-replacement sqlite)
+ "x86_64-linux")
+ (let* ((inferior (open-inferior %top-builddir
+ #:command "scripts/guix"))
+ (packages (inferior-packages inferior)))
+ (match (lookup-inferior-packages inferior
+ (package-name sqlite)
+ (package-version sqlite))
+ ((inferior-sqlite rest ...)
+ (inferior-package-derivation %store
+ (inferior-package-replacement
+ inferior-sqlite)
+ "x86_64-linux")))))
+
(test-equal "inferior-package->manifest-entry"
(manifest-entry->list (package->manifest-entry
(first (find-best-packages-by-name "guile" #f))))
diff --git a/tests/lint.scm b/tests/lint.scm
index bd8604f589..e96265a55a 100644
--- a/tests/lint.scm
+++ b/tests/lint.scm
@@ -1,13 +1,16 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013 Cyril Roelandt <tipecaml@gmail.com>
;;; Copyright © 2014, 2015, 2016 Eric Bavier <bavier@member.fsf.org>
-;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com>
;;; Copyright © 2017 Alex Kost <alezost@gmail.com>
;;; 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.
;;;
@@ -37,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))
@@ -45,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)
@@ -159,6 +163,20 @@
(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
+ (let ((pkg (dummy-package "x"
+ (description "Whitespace. "))))
+ (check-description-style pkg))))
+
(test-equal "synopsis: not a string"
"invalid synopsis: #f"
(single-lint-warning-message
@@ -270,6 +288,42 @@
(description "Imagine this is Taylor UUCP."))))
(check-synopsis-style pkg)))
+(test-equal "synopsis: contains trailing whitespace"
+ "synopsis contains trailing whitespace"
+ (single-lint-warning-message
+ (let ((pkg (dummy-package "x"
+ (synopsis "Whitespace "))))
+ (check-synopsis-style pkg))))
+
+(test-equal "name: use underscore in package name"
+ "name should use hyphens instead of underscores"
+ (single-lint-warning-message
+ (let ((pkg (dummy-package "under_score")))
+ (check-name pkg))))
+
+(test-equal "tests-true: #:tests? must not be set to #t"
+ "#:tests? must not be explicitly set to #t"
+ (single-lint-warning-message
+ (let ((pkg (dummy-package "x" (arguments '(#:tests? #t)))))
+ (check-tests-true pkg))))
+
+(test-equal "tests-true: absent #:tests? is acceptable"
+ '()
+ (let ((pkg (dummy-package "x")))
+ (check-tests-true pkg)))
+
+(test-equal "tests-true: #:tests? #f is acceptable"
+ '()
+ (let ((pkg (dummy-package "x" (arguments '(#:tests? #f)))))
+ (check-tests-true pkg)))
+
+(test-equal "tests-true: #:tests? #t acceptable when compiling natively"
+ '()
+ (let ((pkg (dummy-package "x"
+ (arguments
+ `(#:tests? ,(not (%current-target-system)))))))
+ (check-tests-true pkg)))
+
(test-equal "inputs: pkg-config is probably a native input"
"'pkg-config' should probably be a native input"
(single-lint-warning-message
@@ -312,6 +366,92 @@
`(("python-setuptools" ,python-setuptools))))))
(check-inputs-should-not-be-an-input-at-all 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
@@ -700,6 +840,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))
@@ -1001,10 +1215,13 @@
(method url-fetch)
(uri "http://example.org/foo.tgz")
(sha256 (make-bytevector 32))))
- (warnings (with-http-server '((404 "Not archived."))
+ (warnings (with-http-server '((404 "Not archived.")
+ (404 "Not in Disarchive database."))
(parameterize ((%swh-base-url (%local-url)))
- (check-archival (dummy-package "x"
- (source origin)))))))
+ (mock ((guix download) %disarchive-mirrors
+ (list (%local-url)))
+ (check-archival (dummy-package "x"
+ (source origin))))))))
(warning-contains? "not archived" warnings)))
(test-equal "archival: content available"
@@ -1020,6 +1237,29 @@
(parameterize ((%swh-base-url (%local-url)))
(check-archival (dummy-package "x" (source origin)))))))
+(test-equal "archival: content unavailable but disarchive available"
+ '()
+ (let* ((origin (origin
+ (method url-fetch)
+ (uri "http://example.org/foo.tgz")
+ (sha256 (make-bytevector 32))))
+ (disarchive (object->string
+ '(disarchive (version 0)
+ ...
+ "swh:1:dir:aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")))
+ ;; https://archive.softwareheritage.org/api/1/directory/
+ (directory "[ { \"checksums\": {},
+ \"dir_id\": \"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\",
+ \"type\": \"file\",
+ \"name\": \"README\"
+ \"length\": 42 } ]"))
+ (with-http-server `((404 "") ;lookup-content
+ (200 ,disarchive) ;Disarchive database lookup
+ (200 ,directory)) ;lookup-directory
+ (mock ((guix download) %disarchive-mirrors (list (%local-url)))
+ (parameterize ((%swh-base-url (%local-url)))
+ (check-archival (dummy-package "x" (source origin))))))))
+
(test-assert "archival: missing revision"
(let* ((origin (origin
(method git-fetch)
@@ -1077,29 +1317,30 @@
(test-assert "haskell-stackage"
(let* ((stackage (string-append "{ \"packages\": [{"
- " \"name\":\"x\","
+ " \"name\":\"pandoc\","
+ " \"synopsis\":\"synopsis\","
" \"version\":\"1.0\" }]}"))
(packages (map (lambda (version)
(dummy-package
- (string-append "ghc-x")
+ "ghc-pandoc"
(version version)
(source
(dummy-origin
(method url-fetch)
(uri (string-append
"https://hackage.haskell.org/package/"
- "x-" version "/x-" version ".tar.gz"))))))
- '("0.9" "1.0" "2.0")))
+ "pandoc-" version "/pandoc-" version ".tar.gz"))))))
+ '("0.9" "1.0" "100.0")))
(warnings (pk (with-http-server `((200 ,stackage) ; memoized
- (200 "name: x\nversion: 1.0\n")
- (200 "name: x\nversion: 1.0\n")
- (200 "name: x\nversion: 1.0\n"))
+ (200 "name: pandoc\nversion: 1.0\n")
+ (200 "name: pandoc\nversion: 1.0\n")
+ (200 "name: pandoc\nversion: 1.0\n"))
(parameterize ((%hackage-url (%local-url))
(%stackage-url (%local-url)))
(append-map check-haskell-stackage packages))))))
(match warnings
(((? lint-warning? warning))
- (and (string=? (package-version (lint-warning-package warning)) "2.0")
+ (and (string=? (package-version (lint-warning-package warning)) "100.0")
(string-contains (lint-warning-message warning)
"ahead of Stackage LTS version"))))))
diff --git a/tests/minetest.scm b/tests/minetest.scm
new file mode 100644
index 0000000000..abb26d0a03
--- /dev/null
+++ b/tests/minetest.scm
@@ -0,0 +1,382 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
+;;;
+;;; 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-minetest)
+ #:use-module (guix memoization)
+ #:use-module (guix import minetest)
+ #:use-module (guix import utils)
+ #:use-module (guix tests)
+ #:use-module (json)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-64))
+
+
+;; Some procedures for populating a ‘fake’ ContentDB server.
+
+(define* (make-package-sexp #:key
+ (guix-name "minetest-foo")
+ ;; This is not a proper version number but
+ ;; ContentDB often does not include version
+ ;; numbers.
+ (version "2021-07-25")
+ (home-page "https://example.org/foo")
+ (repo "https://example.org/foo.git")
+ (synopsis "synopsis")
+ (guix-description "description")
+ (guix-license
+ '(list license:cc-by-sa4.0 license:lgpl3+))
+ (inputs '())
+ (upstream-name "Author/foo")
+ #:allow-other-keys)
+ `(package
+ (name ,guix-name)
+ (version ,version)
+ (source
+ (origin
+ (method git-fetch)
+ (uri (git-reference
+ (url ,(and (not (eq? repo 'null)) repo))
+ (commit #f)))
+ (sha256
+ (base32 #f))
+ (file-name (git-file-name name version))))
+ (build-system minetest-mod-build-system)
+ ,@(maybe-propagated-inputs inputs)
+ (home-page ,home-page)
+ (synopsis ,synopsis)
+ (description ,guix-description)
+ (license ,guix-license)
+ (properties
+ ,(list 'quasiquote
+ `((upstream-name . ,upstream-name))))))
+
+(define* (make-package-json #:key
+ (author "Author")
+ (name "foo")
+ (media-license "CC-BY-SA-4.0")
+ (license "LGPL-3.0-or-later")
+ (short-description "synopsis")
+ (long-description "description")
+ (repo "https://example.org/foo.git")
+ (website "https://example.org/foo")
+ (forums 321)
+ (score 987.654)
+ (downloads 123)
+ (type "mod")
+ #:allow-other-keys)
+ `(("author" . ,author)
+ ("content_warnings" . #())
+ ("created_at" . "2018-05-23T19:58:07.422108")
+ ("downloads" . ,downloads)
+ ("forums" . ,forums)
+ ("issue_tracker" . "https://example.org/foo/issues")
+ ("license" . ,license)
+ ("long_description" . ,long-description)
+ ("maintainers" . #("maintainer"))
+ ("media_license" . ,media-license)
+ ("name" . ,name)
+ ("provides" . #("stuff"))
+ ("release" . 456)
+ ("repo" . ,repo)
+ ("score" . ,score)
+ ("screenshots" . #())
+ ("short_description" . ,short-description)
+ ("state" . "APPROVED")
+ ("tags" . #("some" "tags"))
+ ("thumbnail" . null)
+ ("title" . "The name")
+ ("type" . ,type)
+ ("url" . ,(string-append "https://content.minetest.net/packages/"
+ author "/" name "/download/"))
+ ("website" . ,website)))
+
+(define* (make-releases-json #:key (commit #f) (title "2021-07-25") #:allow-other-keys)
+ `#((("commit" . ,commit)
+ ("downloads" . 469)
+ ("id" . 8614)
+ ("max_minetest_version" . null)
+ ("min_minetest_version" . null)
+ ("release_date" . "2021-07-25T01:10:23.207584")
+ ("title" . ,title))))
+
+(define* (make-dependencies-json #:key (author "Author")
+ (name "foo")
+ (requirements '(("default" #f ())))
+ #:allow-other-keys)
+ `((,(string-append author "/" name)
+ . ,(list->vector
+ (map (match-lambda
+ ((symbolic-name optional? implementations)
+ `(("is_optional" . ,optional?)
+ ("name" . ,symbolic-name)
+ ("packages" . ,(list->vector implementations)))))
+ requirements)))
+ ("something/else" . #())))
+
+(define* (make-packages-keys-json #:key (author "Author")
+ (name "Name")
+ (type "mod"))
+ `(("author" . ,author)
+ ("name" . ,name)
+ ("type" . ,type)))
+
+(define (call-with-packages thunk . argument-lists)
+ ;; Don't reuse results from previous tests.
+ (invalidate-memoization! contentdb-fetch)
+ (invalidate-memoization! minetest->guix-package)
+ (define (scm->json-port scm)
+ (open-input-string (scm->json-string scm)))
+ (define (handle-package url requested-author requested-name . rest)
+ (define relevant-argument-list
+ (any (lambda (argument-list)
+ (apply (lambda* (#:key (author "Author") (name "foo")
+ #:allow-other-keys)
+ (and (equal? requested-author author)
+ (equal? requested-name name)
+ argument-list))
+ argument-list))
+ argument-lists))
+ (when (not relevant-argument-list)
+ (error "the package ~a/~a should be irrelevant, but ~a is fetched"
+ requested-author requested-name url))
+ (scm->json-port
+ (apply (match rest
+ (("") make-package-json)
+ (("dependencies" "") make-dependencies-json)
+ (("releases" "") make-releases-json)
+ (_ (error "TODO ~a" rest)))
+ relevant-argument-list)))
+ (define (handle-mod-search sort)
+ ;; Produce search results, sorted by SORT in descending order.
+ (define arguments->key
+ (match sort
+ ("score" (lambda* (#:key (score 987.654) #:allow-other-keys)
+ score))
+ ("downloads" (lambda* (#:key (downloads 123) #:allow-other-keys)
+ downloads))))
+ (define argument-list->key (cut apply arguments->key <>))
+ (define (greater x y)
+ (> (argument-list->key x) (argument-list->key y)))
+ (define sorted-argument-lists (sort-list argument-lists greater))
+ (define* (arguments->json #:key (author "Author") (name "Foo") (type "mod")
+ #:allow-other-keys)
+ (and (string=? type "mod")
+ `(("author" . ,author)
+ ("name" . ,name)
+ ("type" . ,type))))
+ (define argument-list->json (cut apply arguments->json <>))
+ (scm->json-port
+ (list->vector (filter-map argument-list->json sorted-argument-lists))))
+ (mock ((guix http-client) http-fetch
+ (lambda* (url #:key headers)
+ (unless (string-prefix? "mock://api/packages/" url)
+ (error "the URL ~a should not be used" url))
+ (define resource
+ (substring url (string-length "mock://api/packages/")))
+ (define components (string-split resource #\/))
+ (match components
+ ((author name . rest)
+ (apply handle-package url author name rest))
+ (((? (cut string-prefix? "?type=mod&q=" <>) query))
+ (handle-mod-search
+ (cond ((string-contains query "sort=score") "score")
+ ((string-contains query "sort=downloads") "downloads")
+ (#t (error "search query ~a has unknown sort key"
+ query)))))
+ (_
+ (error "the URL ~a should have an author and name component"
+ url)))))
+ (parameterize ((%contentdb-api "mock://api/"))
+ (thunk))))
+
+(define* (minetest->guix-package* #:key (author "Author") (name "foo")
+ (sort %default-sort-key)
+ #:allow-other-keys)
+ (minetest->guix-package (string-append author "/" name) #:sort sort))
+
+(define (imported-package-sexp* primary-arguments . secondary-arguments)
+ "Ask the importer to import a package specified by PRIMARY-ARGUMENTS,
+during a dynamic where that package and the packages specified by
+SECONDARY-ARGUMENTS are available on ContentDB."
+ (apply call-with-packages
+ (lambda ()
+ ;; The memoization cache is reset by call-with-packages
+ (apply minetest->guix-package* primary-arguments))
+ primary-arguments
+ secondary-arguments))
+
+(define (imported-package-sexp . extra-arguments)
+ "Ask the importer to import a package specified by EXTRA-ARGUMENTS,
+during a dynamic extent where that package is available on ContentDB."
+ (imported-package-sexp* extra-arguments))
+
+(define-syntax-rule (test-package test-case . extra-arguments)
+ (test-equal test-case
+ (make-package-sexp . extra-arguments)
+ (imported-package-sexp . extra-arguments)))
+
+(define-syntax-rule (test-package* test-case primary-arguments extra-arguments
+ ...)
+ (test-equal test-case
+ (apply make-package-sexp primary-arguments)
+ (imported-package-sexp* primary-arguments extra-arguments ...)))
+
+(test-begin "minetest")
+
+
+;; Package names
+(test-package "minetest->guix-package")
+(test-package "minetest->guix-package, _ → - in package name"
+ #:name "foo_bar"
+ #:guix-name "minetest-foo-bar"
+ #:upstream-name "Author/foo_bar")
+
+(test-equal "elaborate names, unambiguous"
+ "Jeija/mesecons"
+ (call-with-packages
+ (cut elaborate-contentdb-name "mesecons")
+ '(#:name "mesecons" #:author "Jeija")
+ '(#:name "something" #:author "else")))
+
+(test-equal "elaborate name, ambiguous (highest score)"
+ "Jeija/mesecons"
+ (call-with-packages
+ ;; #:sort "score" is the default
+ (cut elaborate-contentdb-name "mesecons")
+ '(#:name "mesecons" #:author "Jeijc" #:score 777)
+ '(#:name "mesecons" #:author "Jeijb" #:score 888)
+ '(#:name "mesecons" #:author "Jeija" #:score 999)))
+
+
+(test-equal "elaborate name, ambiguous (most downloads)"
+ "Jeija/mesecons"
+ (call-with-packages
+ (cut elaborate-contentdb-name "mesecons" #:sort "downloads")
+ '(#:name "mesecons" #:author "Jeijc" #:downloads 777)
+ '(#:name "mesecons" #:author "Jeijb" #:downloads 888)
+ '(#:name "mesecons" #:author "Jeija" #:downloads 999)))
+
+
+;; Determining the home page
+(test-package "minetest->guix-package, website is used as home page"
+ #:home-page "web://site"
+ #:website "web://site")
+(test-package "minetest->guix-package, if absent, the forum is used"
+ #:home-page '(minetest-topic 628)
+ #:forums 628
+ #:website 'null)
+(test-package "minetest->guix-package, if absent, the git repo is used"
+ #:home-page "https://github.com/minetest-mods/mesecons"
+ #:forums 'null
+ #:website 'null
+ #:repo "https://github.com/minetest-mods/mesecons")
+(test-package "minetest->guix-package, all home page information absent"
+ #:home-page #f
+ #:forums 'null
+ #:website 'null
+ #:repo 'null)
+
+
+;; Determining the version number
+
+(test-package "conventional version number" #:version "1.2.3" #:title "1.2.3")
+;; See e.g. orwell/basic_trains
+(test-package "v-prefixed version number" #:version "1.2.3" #:title "v1.2.3")
+;; Many mods on ContentDB use dates as release titles. In that case, the date
+;; will have to do.
+(test-package "dates as version number"
+ #:version "2021-01-01" #:title "2021-01-01")
+
+
+
+;; Dependencies
+(test-package* "minetest->guix-package, unambiguous dependency"
+ (list #:requirements '(("mesecons" #f
+ ("Jeija/mesecons"
+ "some-modpack/containing-mese")))
+ #:inputs '("minetest-mesecons"))
+ (list #:author "Jeija" #:name "mesecons")
+ (list #:author "some-modpack" #:name "containing-mese" #:type "modpack"))
+
+(test-package* "minetest->guix-package, ambiguous dependency (highest score)"
+ (list #:name "frobnicate"
+ #:guix-name "minetest-frobnicate"
+ #:upstream-name "Author/frobnicate"
+ #:requirements '(("frob" #f
+ ("Author/foo" "Author/bar")))
+ ;; #:sort "score" is the default
+ #:inputs '("minetest-bar"))
+ (list #:author "Author" #:name "foo" #:score 0)
+ (list #:author "Author" #:name "bar" #:score 9999))
+
+(test-package* "minetest->guix-package, ambiguous dependency (most downloads)"
+ (list #:name "frobnicate"
+ #:guix-name "minetest-frobnicate"
+ #:upstream-name "Author/frobnicate"
+ #:requirements '(("frob" #f
+ ("Author/foo" "Author/bar")))
+ #:inputs '("minetest-bar")
+ #:sort "downloads")
+ (list #:author "Author" #:name "foo" #:downloads 0)
+ (list #:author "Author" #:name "bar" #:downloads 9999))
+
+(test-package "minetest->guix-package, optional dependency"
+ #:requirements '(("mesecons" #t
+ ("Jeija/mesecons"
+ "some-modpack/containing-mese")))
+ #:inputs '())
+
+;; See e.g. 'orwell/basic_trains'
+(test-package* "minetest->guix-package, multiple dependencies implemented by one mod"
+ (list #:name "frobnicate"
+ #:guix-name "minetest-frobnicate"
+ #:upstream-name "Author/frobnicate"
+ #:requirements '(("frob" #f ("Author/frob"))
+ ("frob_x" #f ("Author/frob")))
+ #:inputs '("minetest-frob"))
+ (list #:author "Author" #:name "frob"))
+
+
+;; License
+(test-package "minetest->guix-package, identical licenses"
+ #:guix-license 'license:lgpl3+
+ #:license "LGPL-3.0-or-later"
+ #:media-license "LGPL-3.0-or-later")
+
+;; Sorting
+(let* ((make-package
+ (lambda arguments
+ (json->package (apply make-package-json arguments))))
+ (x (make-package #:score 0))
+ (y (make-package #:score 1))
+ (z (make-package #:score 2)))
+ (test-equal "sort-packages, already sorted"
+ (list z y x)
+ (sort-packages (list z y x)))
+ (test-equal "sort-packages, reverse"
+ (list z y x)
+ (sort-packages (list x y z))))
+
+(test-end "minetest")
+
+;;; Local Variables:
+;;; eval: (put 'test-package* 'scheme-indent-function 1)
+;;; End:
diff --git a/tests/opam.scm b/tests/opam.scm
index 11984b56a6..31b4ea41ff 100644
--- a/tests/opam.scm
+++ b/tests/opam.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Julien Lepiller <julien@lepiller.eu>
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -55,6 +56,7 @@ depends: [
synopsis: \"Some example package\"
description: \"\"\"
This package is just an example.\"\"\"
+license: \"BSD-3-Clause\"
url {
src: \"https://example.org/foo-1.0.0.tar.gz\"
checksum: \"md5=74c6e897658e820006106f45f736381f\"
@@ -69,26 +71,26 @@ url {
(test-begin "opam")
(test-assert "opam->guix-package"
- (mock ((guix import utils) url-fetch
- (lambda (url file-name)
- (match url
- ("https://example.org/foo-1.0.0.tar.gz"
- (begin
- (mkdir-p "foo-1.0.0")
- (system* "tar" "czvf" file-name "foo-1.0.0/")
- (delete-file-recursively "foo-1.0.0")
- (set! test-source-hash
- (call-with-input-file file-name port-sha256))))
- (_ (error "Unexpected URL: " url)))))
- (mock ((guix import opam) get-opam-repository
- (const test-repo))
+ (mock ((guix import opam) get-opam-repository
+ (const test-repo))
+ (mock ((guix import utils) url-fetch
+ (lambda (url file-name)
+ (match url
+ ("https://example.org/foo-1.0.0.tar.gz"
+ (begin
+ (mkdir-p "foo-1.0.0")
+ (system* "tar" "czvf" file-name "foo-1.0.0/")
+ (delete-file-recursively "foo-1.0.0")
+ (set! test-source-hash
+ (call-with-input-file file-name port-sha256))))
+ (_ (error "Unexpected URL: " url)))))
(let ((my-package (string-append test-repo
"/packages/foo/foo.1.0.0")))
(mkdir-p my-package)
(with-output-to-file (string-append my-package "/opam")
(lambda _
(format #t "~a" test-opam-file))))
- (match (opam->guix-package "foo" #:repo test-repo)
+ (match (opam->guix-package "foo" #:repo (list test-repo))
(('package
('name "ocaml-foo")
('version "1.0.0")
@@ -109,7 +111,7 @@ url {
('home-page "https://example.org/")
('synopsis "Some example package")
('description "This package is just an example.")
- ('license #f))
+ ('license 'license:bsd-3))
(string=? (bytevector->nix-base32-string
test-source-hash)
hash))
diff --git a/tests/pack.scm b/tests/pack.scm
index e8455b4f37..e9b4c36e0e 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 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"
#~(#+(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/packages.scm b/tests/packages.scm
index 2a290bc353..3756877270 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -236,6 +236,17 @@
(eq? item new)))
(null? (manifest-transaction-remove tx)))))))
+(test-assert "package-definition-location"
+ (let ((location (package-location hello))
+ (definition (package-definition-location hello)))
+ ;; Check for the usual layout of (define-public hello (package ...)).
+ (and (string=? (location-file location)
+ (location-file definition))
+ (= 0 (location-column definition))
+ (= 2 (location-column location))
+ (= (location-line definition)
+ (- (location-line location) 1)))))
+
(test-assert "package-field-location"
(let ()
(define (goto port line column)
diff --git a/tests/profiles.scm b/tests/profiles.scm
index ce77711d63..06a0387221 100644
--- a/tests/profiles.scm
+++ b/tests/profiles.scm
@@ -279,6 +279,63 @@
(string=? (dirname (readlink bindir))
(derivation->output-path guile))))))
+(test-assertm "profile-derivation, ordering & collisions"
+ ;; ENTRY1 and ENTRY2 both provide 'bin/guile'--a collision. Make sure
+ ;; ENTRY1 "wins" over ENTRY2. See <https://bugs.gnu.org/49102>.
+ (mlet* %store-monad
+ ((entry1 -> (package->manifest-entry %bootstrap-guile))
+ (entry2 -> (manifest-entry
+ (name "fake-guile")
+ (version "0")
+ (item (computed-file
+ "fake-guile"
+ #~(begin
+ (mkdir #$output)
+ (mkdir (string-append #$output "/bin"))
+ (call-with-output-file
+ (string-append #$output "/bin/guile")
+ (lambda (port)
+ (display "Fake!\n" port))))))))
+ (guile (package->derivation %bootstrap-guile))
+ (drv (profile-derivation (manifest (list entry1 entry2))
+ #:hooks '()
+ #:locales? #f))
+ (profile -> (derivation->output-path drv))
+ (bindir -> (string-append profile "/bin"))
+ (file -> (string-append bindir "/guile"))
+ (_ (built-derivations (list drv))))
+ (return (string=? (readlink file)
+ (string-append
+ (derivation->output-path guile)
+ "/bin/guile")))))
+
+(test-assertm "load-profile"
+ (mlet* %store-monad
+ ((entry -> (package->manifest-entry %bootstrap-guile))
+ (guile (package->derivation %bootstrap-guile))
+ (drv (profile-derivation (manifest (list entry))
+ #:hooks '()
+ #:locales? #f))
+ (profile -> (derivation->output-path drv))
+ (bindir -> (string-append profile "/bin"))
+ (_ (built-derivations (list drv))))
+ (define-syntax-rule (with-environment-excursion exp ...)
+ (let ((env (environ)))
+ (dynamic-wind
+ (const #t)
+ (lambda () exp ...)
+ (lambda () (environ env)))))
+
+ (return (and (with-environment-excursion
+ (load-profile profile)
+ (and (string-prefix? (string-append bindir ":")
+ (getenv "PATH"))
+ (getenv "GUILE_LOAD_PATH")))
+ (with-environment-excursion
+ (load-profile profile #:pure? #t #:white-list '())
+ (equal? (list (string-append "PATH=" bindir))
+ (environ)))))))
+
(test-assertm "<profile>"
(mlet* %store-monad
((entry -> (package->manifest-entry %bootstrap-guile))
diff --git a/tests/publish.scm b/tests/publish.scm
index 3e67c435ac..c3d086995a 100644
--- a/tests/publish.scm
+++ b/tests/publish.scm
@@ -1,7 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2020 by Amar M. Singh <nly@disroot.org>
-;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -700,6 +700,36 @@ References: ~%"
(= (response-content-length response) (stat:size (stat log)))
(first (response-content-type response))))))
+(test-equal "negative TTL"
+ `(404 42)
+
+ (call-with-temporary-directory
+ (lambda (cache)
+ (let ((thread (with-separate-output-ports
+ (call-with-new-thread
+ (lambda ()
+ (guix-publish "--port=6786" "-C0"
+ "--negative-ttl=42s"))))))
+ (wait-until-ready 6786)
+
+ (let* ((base "http://localhost:6786/")
+ (url (string-append base (make-string 32 #\z)
+ ".narinfo"))
+ (response (http-get url)))
+ (list (response-code response)
+ (match (assq-ref (response-headers response) 'cache-control)
+ ((('max-age . ttl)) ttl)
+ (_ #f))))))))
+
+(test-equal "no negative TTL"
+ `(404 #f)
+ (let* ((uri (publish-uri
+ (string-append "/" (make-string 32 #\z)
+ ".narinfo")))
+ (response (http-get uri)))
+ (list (response-code response)
+ (assq-ref (response-headers response) 'cache-control))))
+
(test-equal "/log/NAME not found"
404
(let ((uri (publish-uri "/log/does-not-exist")))
diff --git a/tests/pypi.scm b/tests/pypi.scm
index f421d6d9df..70f4298a90 100644
--- a/tests/pypi.scm
+++ b/tests/pypi.scm
@@ -2,6 +2,7 @@
;;; Copyright © 2014 David Thompson <davet@gnu.org>
;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -29,7 +30,7 @@
#:use-module (srfi srfi-64)
#:use-module (ice-9 match))
-(define test-json
+(define test-json-1
"{
\"info\": {
\"version\": \"1.0.0\",
@@ -57,6 +58,34 @@
}
}")
+(define test-json-2
+ "{
+ \"info\": {
+ \"version\": \"1.0.0\",
+ \"name\": \"foo-99\",
+ \"license\": \"GNU LGPL\",
+ \"summary\": \"summary\",
+ \"home_page\": \"http://example.com\",
+ \"classifiers\": [],
+ \"download_url\": \"\"
+ },
+ \"urls\": [],
+ \"releases\": {
+ \"1.0.0\": [
+ {
+ \"url\": \"https://example.com/foo-99-1.0.0.egg\",
+ \"packagetype\": \"bdist_egg\"
+ }, {
+ \"url\": \"https://example.com/foo-99-1.0.0.tar.gz\",
+ \"packagetype\": \"sdist\"
+ }, {
+ \"url\": \"https://example.com/foo-99-1.0.0-py2.py3-none-any.whl\",
+ \"packagetype\": \"bdist_wheel\"
+ }
+ ]
+ }
+}")
+
(define test-source-hash
"")
@@ -147,6 +176,13 @@ Requires-Dist: pytest (>=3.1.0); extra == 'testing'
(uri (list "https://bitheap.org/cram/cram-0.7.tar.gz"
(pypi-uri "cram" "0.7"))))))))
+(test-equal "guix-package->pypi-name, honor 'upstream-name'"
+ "bar-3"
+ (guix-package->pypi-name
+ (dummy-package "foo"
+ (properties
+ '((upstream-name . "bar-3"))))))
+
(test-equal "specification->requirement-name"
'("Fizzy" "PickyThing" "SomethingWithMarker" "requests" "pip")
(map specification->requirement-name test-specifications))
@@ -198,8 +234,8 @@ Requires-Dist: pytest (>=3.1.0); extra == 'testing'
(lambda (url . rest)
(match url
("https://pypi.org/pypi/foo/json"
- (values (open-input-string test-json)
- (string-length test-json)))
+ (values (open-input-string test-json-1)
+ (string-length test-json-1)))
("https://example.com/foo-1.0.0-py2.py3-none-any.whl" #f)
(_ (error "Unexpected URL: " url)))))
(match (pypi->guix-package "foo")
@@ -264,8 +300,8 @@ Requires-Dist: pytest (>=3.1.0); extra == 'testing'
(lambda (url . rest)
(match url
("https://pypi.org/pypi/foo/json"
- (values (open-input-string test-json)
- (string-length test-json)))
+ (values (open-input-string test-json-1)
+ (string-length test-json-1)))
("https://example.com/foo-1.0.0-py2.py3-none-any.whl" #f)
(_ (error "Unexpected URL: " url)))))
;; Not clearing the memoization cache here would mean returning the value
@@ -317,8 +353,8 @@ Requires-Dist: pytest (>=3.1.0); extra == 'testing'
(lambda (url . rest)
(match url
("https://pypi.org/pypi/foo/json"
- (values (open-input-string test-json)
- (string-length test-json)))
+ (values (open-input-string test-json-1)
+ (string-length test-json-1)))
("https://example.com/foo-1.0.0-py2.py3-none-any.whl" #f)
(_ (error "Unexpected URL: " url)))))
;; Not clearing the memoization cache here would mean returning the value
@@ -345,4 +381,60 @@ Requires-Dist: pytest (>=3.1.0); extra == 'testing'
(x
(pk 'fail x #f))))))
+(test-assert "pypi->guix-package, package name contains \"-\" followed by digits"
+ ;; Replace network resources with sample data.
+ (mock ((guix import utils) url-fetch
+ (lambda (url file-name)
+ (match url
+ ("https://example.com/foo-99-1.0.0.tar.gz"
+ (begin
+ ;; Unusual requires.txt location should still be found.
+ (mkdir-p "foo-99-1.0.0/src/bizarre.egg-info")
+ (with-output-to-file "foo-99-1.0.0/src/bizarre.egg-info/requires.txt"
+ (lambda ()
+ (display test-requires.txt)))
+ (parameterize ((current-output-port (%make-void-port "rw+")))
+ (system* "tar" "czvf" file-name "foo-99-1.0.0/"))
+ (delete-file-recursively "foo-99-1.0.0")
+ (set! test-source-hash
+ (call-with-input-file file-name port-sha256))))
+ ("https://example.com/foo-99-1.0.0-py2.py3-none-any.whl" #f)
+ (_ (error "Unexpected URL: " url)))))
+ (mock ((guix http-client) http-fetch
+ (lambda (url . rest)
+ (match url
+ ("https://pypi.org/pypi/foo-99/json"
+ (values (open-input-string test-json-2)
+ (string-length test-json-2)))
+ ("https://example.com/foo-99-1.0.0-py2.py3-none-any.whl" #f)
+ (_ (error "Unexpected URL: " url)))))
+ (match (pypi->guix-package "foo-99")
+ (('package
+ ('name "python-foo-99")
+ ('version "1.0.0")
+ ('source ('origin
+ ('method 'url-fetch)
+ ('uri ('pypi-uri "foo-99" 'version))
+ ('sha256
+ ('base32
+ (? string? hash)))))
+ ('properties ('quote (("upstream-name" . "foo-99"))))
+ ('build-system 'python-build-system)
+ ('propagated-inputs
+ ('quasiquote
+ (("python-bar" ('unquote 'python-bar))
+ ("python-foo" ('unquote 'python-foo)))))
+ ('native-inputs
+ ('quasiquote
+ (("python-pytest" ('unquote 'python-pytest)))))
+ ('home-page "http://example.com")
+ ('synopsis "summary")
+ ('description "summary")
+ ('license 'license:lgpl2.0))
+ (string=? (bytevector->nix-base32-string
+ test-source-hash)
+ hash))
+ (x
+ (pk 'fail x #f))))))
+
(test-end "pypi")
diff --git a/tests/records.scm b/tests/records.scm
index 2c55a61720..d014e7a995 100644
--- a/tests/records.scm
+++ b/tests/records.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -29,6 +29,16 @@
(module-use! module (resolve-interface '(guix records)))
module))
+(define (location-alist loc)
+ ;; Return a location alist. In Guile < 3.0.6, LOC is always an alist, but
+ ;; starting with 3.0.6, LOC is a vector (at least when it comes from
+ ;; 'syntax-error' exceptions), hence this conversion.
+ (match loc
+ (#(file line column)
+ `((line . ,line) (column . ,column)
+ (filename . ,file)))
+ (_ loc)))
+
(test-begin "records")
@@ -273,6 +283,44 @@
(equal? (foo-bar y) 1)) ;promise was already forced
(eq? (foo-baz y) 'b)))))
+(test-assert "define-record-type* & sanitize"
+ (begin
+ (define-record-type* <foo> foo make-foo
+ foo?
+ (bar foo-bar
+ (default "bar")
+ (sanitize (lambda (x) (string-append x "!")))))
+
+ (let* ((p (foo))
+ (q (foo (inherit p)))
+ (r (foo (inherit p) (bar "baz")))
+ (s (foo (bar "baz"))))
+ (and (string=? (foo-bar p) "bar!")
+ (equal? q p)
+ (string=? (foo-bar r) "baz!")
+ (equal? s r)))))
+
+(test-assert "define-record-type* & sanitize & thunked"
+ (let ((sanitized 0))
+ (define-record-type* <foo> foo make-foo
+ foo?
+ (bar foo-bar
+ (default "bar")
+ (sanitize (lambda (x)
+ (set! sanitized (+ 1 sanitized))
+ (string-append x "!")))))
+
+ (let ((p (foo)))
+ (and (string=? (foo-bar p) "bar!")
+ (string=? (foo-bar p) "bar!") ;twice
+ (= sanitized 1) ;sanitizer was called at init time only
+ (let ((q (foo (bar "baz"))))
+ (and (string=? (foo-bar q) "baz!")
+ (string=? (foo-bar q) "baz!") ;twice
+ (= sanitized 2)
+ (let ((r (foo (inherit q))))
+ (and (string=? (foo-bar r) "baz!")
+ (= sanitized 2))))))))) ;no re-sanitization
(test-assert "define-record-type* & wrong field specifier"
(let ((exp '(begin
(define-record-type* <foo> foo make-foo
@@ -298,7 +346,7 @@
(pk 'expected-loc
`((line . ,(- (assq-ref loc 'line) 1))
,@(alist-delete 'line loc)))
- (pk 'actual-loc location)))))))
+ (pk 'actual-loc (location-alist location))))))))
(test-assert "define-record-type* & wrong field specifier, identifier"
(let ((exp '(begin
@@ -325,7 +373,7 @@
(pk 'expected-loc
`((line . ,(- (assq-ref loc 'line) 2))
,@(alist-delete 'line loc)))
- (pk 'actual-loc location)))))))
+ (pk 'actual-loc (location-alist location))))))))
(test-assert "define-record-type* & missing initializers"
(catch 'syntax-error
@@ -396,7 +444,7 @@
(pk 'expected-loc
`((line . ,(- (assq-ref loc 'line) 1))
,@(alist-delete 'line loc)))
- (pk 'actual-loc location)))))))
+ (pk 'actual-loc (location-alist location))))))))
(test-assert "ABI checks"
(let ((module (test-module)))
diff --git a/tests/services/configuration.scm b/tests/services/configuration.scm
new file mode 100644
index 0000000000..86a36a388d
--- /dev/null
+++ b/tests/services/configuration.scm
@@ -0,0 +1,120 @@
+;;; 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.
+;;;
+;;; 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 (tests services configuration)
+ #:use-module (gnu services configuration)
+ #:use-module (guix gexp)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-64))
+
+;;; Tests for the (gnu services configuration) module.
+
+(test-begin "services-configuration")
+
+
+;;;
+;;; define-configuration macro.
+;;;
+
+(define-configuration port-configuration
+ (port (number 80) "The port number.")
+ (no-serialization))
+
+(test-equal "default value, no serialization"
+ 80
+ (port-configuration-port (port-configuration)))
+
+(define-configuration port-configuration-cs
+ (port (number 80) "The port number." empty-serializer))
+
+(test-equal "default value, custom serializer"
+ 80
+ (port-configuration-cs-port (port-configuration-cs)))
+
+(define serialize-number "")
+(define-configuration port-configuration-ndv
+ (port (number) "The port number."))
+
+(test-equal "no default value, provided"
+ 55
+ (port-configuration-ndv-port (port-configuration-ndv
+ (port 55))))
+
+(test-assert "no default value, not provided"
+ (guard (c ((configuration-error? c)
+ #t))
+ (port-configuration-ndv-port (port-configuration-ndv))))
+
+(define (custom-number-serializer name value)
+ (format #f "~a = ~a;" name value))
+
+(define-configuration serializable-configuration
+ (port (number 80) "The port number." custom-number-serializer))
+
+(test-assert "serialize-configuration"
+ (gexp?
+ (let ((config (serializable-configuration)))
+ (serialize-configuration config serializable-configuration-fields))))
+
+(define-configuration serializable-configuration
+ (port (number 80) "The port number." custom-number-serializer)
+ (no-serialization))
+
+(test-assert "serialize-configuration with no-serialization"
+ ;; When serialization is disabled, the serializer is set to #f, so
+ ;; attempting to use it fails with a 'wrong-type-arg' error.
+ (not (false-if-exception
+ (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.
+;;;
+(define-maybe number)
+
+(define-configuration config-with-maybe-number
+ (port (maybe-number 80) "The port number."))
+
+(define (serialize-number field value)
+ (format #f "~a=~a" field value))
+
+(test-equal "maybe value serialization"
+ "port=80"
+ (serialize-maybe-number "port" 80))
+
+(define-maybe/no-serialization string)
+
+(define-configuration config-with-maybe-string/no-serialization
+ (name (maybe-string) "The name of the item.")
+ (no-serialization))
+
+(test-assert "maybe value without serialization no procedure bound"
+ (not (defined? 'serialize-maybe-string)))
diff --git a/tests/services/telephony.scm b/tests/services/telephony.scm
new file mode 100644
index 0000000000..b4a0f120d4
--- /dev/null
+++ b/tests/services/telephony.scm
@@ -0,0 +1,446 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;;
+;;; 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 (tests services telephony)
+ #:use-module (gnu build jami-service)
+ #:use-module (gnu services telephony)
+ #:use-module (srfi srfi-64))
+
+;;; Tests for the (gnu services telephony) and related modules.
+
+(test-begin "jami-service")
+
+(define parse-dbus-reply
+ (@@ (gnu build jami-service) parse-dbus-reply))
+
+(define parse-account-ids
+ (@@ (gnu build jami-service) parse-account-ids))
+
+(define parse-account-details
+ (@@ (gnu build jami-service) parse-account-details))
+
+(define parse-contacts
+ (@@ (gnu build jami-service) parse-contacts))
+
+(define jami-account->alist
+ (@@ (gnu services telephony) jami-account->alist))
+
+;; $ dbus-send --print-reply --dest="cx.ring.Ring" \
+;; "/cx/ring/Ring/ConfigurationManager" \
+;; "cx.ring.Ring.ConfigurationManager.getAccountList"
+(define getAccountList-reply "\
+method return time=1622217253.386711 sender=:1.7 -> destination=:1.14 serial=140 reply_serial=2
+ array [
+ string \"addf37fbb558d6a0\"
+ string \"d5cbeb7d08c98a65\"
+ string \"398af0c6b74ce101\"
+ ]
+")
+
+(test-equal "parse-account-ids"
+ '("addf37fbb558d6a0" "d5cbeb7d08c98a65" "398af0c6b74ce101")
+ (parse-account-ids getAccountList-reply))
+
+;; $ dbus-send --print-reply --dest="cx.ring.Ring" \
+;; "/cx/ring/Ring/ConfigurationManager" \
+;; "cx.ring.Ring.ConfigurationManager.getAccountDetails" \
+;; 'string:398af0c6b74ce101'
+(define getAccountDetails-reply "\
+method return time=1622254991.789588 sender=:1.7 -> destination=:1.19 serial=145 reply_serial=2
+ array [
+ dict entry(
+ string \"Account.accountDiscovery\"
+ string \"false\"
+ )
+ dict entry(
+ string \"Account.accountPublish\"
+ string \"false\"
+ )
+ dict entry(
+ string \"Account.activeCallLimit\"
+ string \"-1\"
+ )
+ dict entry(
+ string \"Account.alias\"
+ string \"some-rendezvous-point-name\"
+ )
+ dict entry(
+ string \"Account.allModeratorEnabled\"
+ string \"true\"
+ )
+ dict entry(
+ string \"Account.allowCertFromContact\"
+ string \"true\"
+ )
+ dict entry(
+ string \"Account.allowCertFromHistory\"
+ string \"true\"
+ )
+ dict entry(
+ string \"Account.allowCertFromTrusted\"
+ string \"true\"
+ )
+ dict entry(
+ string \"Account.archiveHasPassword\"
+ string \"false\"
+ )
+ dict entry(
+ string \"Account.audioPortMax\"
+ string \"32766\"
+ )
+ dict entry(
+ string \"Account.audioPortMin\"
+ string \"16384\"
+ )
+ dict entry(
+ string \"Account.autoAnswer\"
+ string \"false\"
+ )
+ dict entry(
+ string \"Account.defaultModerators\"
+ string \"\"
+ )
+ dict entry(
+ string \"Account.deviceID\"
+ string \"94b4070fc7a8afa8482c777a9822c52e6af2e1bd\"
+ )
+ dict entry(
+ string \"Account.deviceName\"
+ string \"some-device\"
+ )
+ dict entry(
+ string \"Account.dhtProxyListUrl\"
+ string \"https://config.jami.net/proxyList\"
+ )
+ dict entry(
+ string \"Account.displayName\"
+ string \"some-rendezvous-point-name\"
+ )
+ dict entry(
+ string \"Account.dtmfType\"
+ string \"overrtp\"
+ )
+ dict entry(
+ string \"Account.enable\"
+ string \"true\"
+ )
+ dict entry(
+ string \"Account.hasCustomUserAgent\"
+ string \"false\"
+ )
+ dict entry(
+ string \"Account.hostname\"
+ string \"bootstrap.jami.net\"
+ )
+ dict entry(
+ string \"Account.localInterface\"
+ string \"default\"
+ )
+ dict entry(
+ string \"Account.localModeratorsEnabled\"
+ string \"true\"
+ )
+ dict entry(
+ string \"Account.mailbox\"
+ string \"\"
+ )
+ dict entry(
+ string \"Account.managerUri\"
+ string \"\"
+ )
+ dict entry(
+ string \"Account.managerUsername\"
+ string \"\"
+ )
+ dict entry(
+ string \"Account.peerDiscovery\"
+ string \"false\"
+ )
+ dict entry(
+ string \"Account.presenceSubscribeSupported\"
+ string \"true\"
+ )
+ dict entry(
+ string \"Account.proxyEnabled\"
+ string \"false\"
+ )
+ dict entry(
+ string \"Account.proxyPushToken\"
+ string \"\"
+ )
+ dict entry(
+ string \"Account.proxyServer\"
+ string \"dhtproxy.jami.net:[80-95]\"
+ )
+ dict entry(
+ string \"Account.publishedAddress\"
+ string \"\"
+ )
+ dict entry(
+ string \"Account.publishedPort\"
+ string \"5060\"
+ )
+ dict entry(
+ string \"Account.publishedSameAsLocal\"
+ string \"true\"
+ )
+ dict entry(
+ string \"Account.rendezVous\"
+ string \"true\"
+ )
+ dict entry(
+ string \"Account.ringtoneEnabled\"
+ string \"true\"
+ )
+ dict entry(
+ string \"Account.ringtonePath\"
+ string \"/usr/share/ring/ringtones/default.opus\"
+ )
+ dict entry(
+ string \"Account.type\"
+ string \"RING\"
+ )
+ dict entry(
+ string \"Account.upnpEnabled\"
+ string \"true\"
+ )
+ dict entry(
+ string \"Account.useragent\"
+ string \"\"
+ )
+ dict entry(
+ string \"Account.username\"
+ string \"ccb8bbe2382343f7feb140710ab48aaf1b55634e\"
+ )
+ dict entry(
+ string \"Account.videoEnabled\"
+ string \"true\"
+ )
+ dict entry(
+ string \"Account.videoPortMax\"
+ string \"65534\"
+ )
+ dict entry(
+ string \"Account.videoPortMin\"
+ string \"49152\"
+ )
+ dict entry(
+ string \"DHT.PublicInCalls\"
+ string \"true\"
+ )
+ dict entry(
+ string \"DHT.port\"
+ string \"7766\"
+ )
+ dict entry(
+ string \"RingNS.account\"
+ string \"3989b55313a911b6f0c004748b49b254f35c9ef6\"
+ )
+ dict entry(
+ string \"RingNS.uri\"
+ string \"\"
+ )
+ dict entry(
+ string \"SRTP.enable\"
+ string \"true\"
+ )
+ dict entry(
+ string \"SRTP.keyExchange\"
+ string \"sdes\"
+ )
+ dict entry(
+ string \"SRTP.rtpFallback\"
+ string \"false\"
+ )
+ dict entry(
+ string \"STUN.enable\"
+ string \"false\"
+ )
+ dict entry(
+ string \"STUN.server\"
+ string \"\"
+ )
+ dict entry(
+ string \"TLS.certificateFile\"
+ string \"/var/lib/jami/.local/share/jami/398af0c6b74ce101/ring_device.crt\"
+ )
+ dict entry(
+ string \"TLS.certificateListFile\"
+ string \"\"
+ )
+ dict entry(
+ string \"TLS.ciphers\"
+ string \"\"
+ )
+ dict entry(
+ string \"TLS.method\"
+ string \"Automatic\"
+ )
+ dict entry(
+ string \"TLS.negotiationTimeoutSec\"
+ string \"-1\"
+ )
+ dict entry(
+ string \"TLS.password\"
+ string \"\"
+ )
+ dict entry(
+ string \"TLS.privateKeyFile\"
+ string \"/var/lib/jami/.local/share/jami/398af0c6b74ce101/ring_device.key\"
+ )
+ dict entry(
+ string \"TLS.requireClientCertificate\"
+ string \"true\"
+ )
+ dict entry(
+ string \"TLS.serverName\"
+ string \"\"
+ )
+ dict entry(
+ string \"TLS.verifyClient\"
+ string \"true\"
+ )
+ dict entry(
+ string \"TLS.verifyServer\"
+ string \"true\"
+ )
+ dict entry(
+ string \"TURN.enable\"
+ string \"true\"
+ )
+ dict entry(
+ string \"TURN.password\"
+ string \"ring\"
+ )
+ dict entry(
+ string \"TURN.realm\"
+ string \"ring\"
+ )
+ dict entry(
+ string \"TURN.server\"
+ string \"turn.jami.net\"
+ )
+ dict entry(
+ string \"TURN.username\"
+ string \"ring\"
+ )
+ ]
+")
+
+(test-equal "parse-account-details; username, alias and display name"
+ '("ccb8bbe2382343f7feb140710ab48aaf1b55634e" ;username
+ "some-rendezvous-point-name" ;alias
+ "some-rendezvous-point-name") ;displayName
+ (let ((account-details (parse-account-details getAccountDetails-reply)))
+ (list (assoc-ref account-details "Account.username")
+ (assoc-ref account-details "Account.alias")
+ (assoc-ref account-details "Account.displayName"))))
+
+(define getContacts-reply "\
+method return time=1627014042.752673 sender=:1.113 -> destination=:1.186 serial=220 reply_serial=2
+ array [
+ array [
+ dict entry(
+ string \"added\"
+ string \"1578883327\"
+ )
+ dict entry(
+ string \"confirmed\"
+ string \"true\"
+ )
+ dict entry(
+ string \"id\"
+ string \"1c7d5a09464223442549fef172a3cf6f4de9b01c\"
+ )
+ ]
+ array [
+ dict entry(
+ string \"added\"
+ string \"1623107941\"
+ )
+ dict entry(
+ string \"confirmed\"
+ string \"true\"
+ )
+ dict entry(
+ string \"id\"
+ string \"5903c6c9ac5cb863c64e559add3d5d1c8c563449\"
+ )
+ ]
+ array [
+ dict entry(
+ string \"added\"
+ string \"1595996256\"
+ )
+ dict entry(
+ string \"confirmed\"
+ string \"true\"
+ )
+ dict entry(
+ string \"id\"
+ string \"ff2d72a548693214fb3a0f0f7a943b5e2bb9be03\"
+ )
+ ]
+ ]")
+
+(test-equal "parse-account-contacts"
+ '((("added" . "1578883327")
+ ("confirmed" . "true")
+ ("id" . "1c7d5a09464223442549fef172a3cf6f4de9b01c"))
+ (("added" . "1623107941")
+ ("confirmed" . "true")
+ ("id" . "5903c6c9ac5cb863c64e559add3d5d1c8c563449"))
+ (("added" . "1595996256")
+ ("confirmed" . "true")
+ ("id" . "ff2d72a548693214fb3a0f0f7a943b5e2bb9be03")))
+ (parse-contacts getContacts-reply))
+
+(define getContacts-empty-reply "\
+method return time=1627400787.873988 sender=:1.1197 -> destination=:1.1463 serial=2127 reply_serial=2
+ array [
+ ]")
+
+(test-equal "parse-account-contacts, empty array"
+ '()
+ (parse-contacts getContacts-empty-reply))
+
+(define %dummy-jami-account (jami-account
+ (archive "/tmp/dummy.gz")))
+
+(define %dummy-jami-account-2 (jami-account
+ (archive "/tmp/dummy.gz")
+ (rendezvous-point? #t)
+ (peer-discovery? #f)
+ (bootstrap-hostnames '("bootstrap.me"
+ "fallback.another.host"))
+ (name-server-uri "https://my.name.server")))
+
+(test-equal "jami-account->alist, no account detail value set"
+ '()
+ (jami-account->alist %dummy-jami-account))
+
+(test-equal "jami-account->alist, with account detail values"
+ '(("Account.hostname" . "bootstrap.me;fallback.another.host")
+ ("Account.peerDiscovery" . "false")
+ ("Account.rendezVous" . "true")
+ ("RingNS.uri" . "https://my.name.server"))
+ (sort (jami-account->alist %dummy-jami-account-2)
+ (lambda (x y)
+ (string<=? (car x) (car y)))))
+
+(test-end)
diff --git a/tests/snix.scm b/tests/snix.scm
deleted file mode 100644
index 4c31e3389d..0000000000
--- a/tests/snix.scm
+++ /dev/null
@@ -1,73 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2015 Ludovic Courtès <ludo@gnu.org>
-;;;
-;;; 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-snix)
- #:use-module (guix import snix)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-64)
- #:use-module (ice-9 match))
-
-(define %nixpkgs-directory
- (getenv "NIXPKGS"))
-
-(define factorize-uri
- (@@ (guix import snix) factorize-uri))
-
-(define-syntax-rule (every? proc lists ...)
- (not (not (every proc lists ...))))
-
-(test-begin "snix")
-
-(test-assert "factorize-uri"
- (every? (match-lambda
- ((uri version '-> expected)
- (equal? (factorize-uri uri version)
- expected)))
- '(("http://example.com/foo.tgz" "1.0"
- -> "http://example.com/foo.tgz")
- ("http://example.com/foo-2.8.tgz" "2.8"
- -> ("http://example.com/foo-" version ".tgz"))
- ("http://example.com/2.8/foo-2.8.tgz" "2.8"
- -> ("http://example.com/" version "/foo-" version ".tgz")))))
-
-(test-skip (if (and %nixpkgs-directory
- (file-exists? (string-append %nixpkgs-directory
- "/default.nix")))
- 0
- 1))
-
-(test-assert "nixpkgs->guix-package"
- (match (nixpkgs->guix-package %nixpkgs-directory "guile")
- (('package
- ('name "guile")
- ('version (? string?))
- ('source ('origin _ ...))
- ('build-system _)
- ('inputs ('quasiquote (inputs ...)))
- ('propagated-inputs ('quasiquote (pinputs ...)))
- ('home-page (? string?))
- ('synopsis (? string?))
- ('description (? string?))
- ('license (? symbol?)))
- (and (member '("libffi" ,libffi) inputs)
- (member '("gmp" ,gmp) pinputs)
- #t))
- (x
- (pk 'fail x #f))))
-
-(test-end "snix")
diff --git a/tests/store.scm b/tests/store.scm
index 9c25adf5e9..95f47c3af3 100644
--- a/tests/store.scm
+++ b/tests/store.scm
@@ -308,42 +308,6 @@
(null? (references %store t1))
(null? (referrers %store t2)))))
-(test-assert "references/substitutes missing reference info"
- (with-store s
- (set-build-options s #:use-substitutes? #f)
- (guard (c ((store-protocol-error? c) #t))
- (let* ((b (add-to-store s "bash" #t "sha256"
- (search-bootstrap-binary "bash"
- (%current-system))))
- (d (derivation s "the-thing" b '("--help")
- #:inputs `((,b)))))
- (references/substitutes s (list (derivation->output-path d) b))
- #f))))
-
-(test-assert "references/substitutes with substitute info"
- (with-store s
- (set-build-options s #:use-substitutes? #t)
- (let* ((t1 (add-text-to-store s "random1" (random-text)))
- (t2 (add-text-to-store s "random2" (random-text)
- (list t1)))
- (t3 (add-text-to-store s "build" "echo -n $t2 > $out"))
- (b (add-to-store s "bash" #t "sha256"
- (search-bootstrap-binary "bash"
- (%current-system))))
- (d (derivation s "the-thing" b `("-e" ,t3)
- #:inputs `((,b) (,t3) (,t2))
- #:env-vars `(("t2" . ,t2))))
- (o (derivation->output-path d)))
- (with-derivation-narinfo d
- (sha256 => (gcrypt:sha256 (string->utf8 t2)))
- (references => (list t2))
-
- (equal? (references/substitutes s (list o t3 t2 t1))
- `((,t2) ;refs of O
- () ;refs of T3
- (,t1) ;refs of T2
- ())))))) ;refs of T1
-
(test-equal "substitutable-path-info when substitutes are turned off"
'()
(with-store s
@@ -490,6 +454,42 @@
(derivation->output-path drv)))
(list d1 d2)))))
+(test-equal "map/accumulate-builds cutoff" ;https://issues.guix.gnu.org/50264
+ (iota 20)
+
+ ;; Make sure that, when the cutoff is reached, 'map/accumulate-builds' still
+ ;; returns the right result and calls the build handler by batches.
+ (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
+ (s (add-to-store %store "bash" #t "sha256"
+ (search-bootstrap-binary "bash"
+ (%current-system))))
+ (d (map (lambda (i)
+ (derivation %store (string-append "the-thing-"
+ (number->string i))
+ s `("-e" ,b)
+ #:env-vars `(("foo" . ,(random-text)))
+ #:sources (list b s)
+ #:properties `((n . ,i))))
+ (iota 20)))
+ (calls '()))
+ (define lst
+ (with-build-handler (lambda (continue store things mode)
+ (set! calls (cons things calls))
+ (continue #f))
+ (map/accumulate-builds %store
+ (lambda (d)
+ (build-derivations %store (list d))
+ (assq-ref (derivation-properties d) 'n))
+ d
+ #:cutoff 7)))
+
+ (match (reverse calls)
+ (((batch1 ...) (batch2 ...) (batch3 ...))
+ (and (equal? (map derivation-file-name (take d 8)) batch1)
+ (equal? (map derivation-file-name (take (drop d 8) 8)) batch2)
+ (equal? (map derivation-file-name (drop d 16)) batch3)
+ lst)))))
+
(test-assert "mapm/accumulate-builds"
(let* ((d1 (run-with-store %store
(gexp->derivation "foo" #~(mkdir #$output))))
diff --git a/tests/system.scm b/tests/system.scm
index 9416b950e6..019c720e65 100644
--- a/tests/system.scm
+++ b/tests/system.scm
@@ -39,7 +39,7 @@
(locale "en_US.utf8")
(bootloader (bootloader-configuration
(bootloader grub-bootloader)
- (target "/dev/sdX")))
+ (targets '("/dev/sdX"))))
(file-systems (cons %root-fs %base-file-systems))
(users %base-user-accounts)))
@@ -56,7 +56,7 @@
(locale "en_US.utf8")
(bootloader (bootloader-configuration
(bootloader grub-bootloader)
- (target "/dev/sdX")))
+ (targets '("/dev/sdX"))))
(mapped-devices (list %luks-device))
(file-systems (cons (file-system
(inherit %root-fs)
diff --git a/tests/transformations.scm b/tests/transformations.scm
index 902bd45a6a..09839dc1c5 100644
--- a/tests/transformations.scm
+++ b/tests/transformations.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2021 Marius Bakke <marius@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -29,7 +30,10 @@
#:use-module (guix build-system)
#:use-module (guix build-system gnu)
#:use-module (guix transformations)
- #:use-module ((guix gexp) #:select (local-file? local-file-file))
+ #:use-module ((guix gexp)
+ #:select (local-file? local-file-file
+ computed-file? computed-file-gexp
+ gexp-input-thing))
#:use-module (guix ui)
#:use-module (guix utils)
#:use-module (guix git)
@@ -232,6 +236,26 @@
(string=? (package-name dep2) "chbouib")
(package-source dep2))))))))
+(test-equal "options->transformation, with-commit, version transformation"
+ '("1.0" "1.0-rc1-2-gabc123" "git.abc123")
+ (map (lambda (commit)
+ (let* ((p (dummy-package "guix.scm"
+ (inputs `(("foo" ,(dummy-package "chbouib"
+ (source (origin
+ (method git-fetch)
+ (uri (git-reference
+ (url "https://example.org")
+ (commit "cabba9e")))
+ (sha256 #f)))))))))
+ (t (options->transformation
+ `((with-commit . ,(string-append "chbouib=" commit))))))
+ (let ((new (t p)))
+ (and (not (eq? new p))
+ (match (package-inputs new)
+ ((("foo" dep1))
+ (package-version dep1)))))))
+ '("v1.0" "1.0-rc1-2-gabc123" "abc123")))
+
(test-equal "options->transformation, with-git-url"
(let ((source (git-checkout (url "https://example.org")
(recursive? #t))))
@@ -400,6 +424,31 @@
(map local-file-file
(origin-patches (package-source dep)))))))))
+(test-equal "options->transformation, with-commit + with-patch"
+ '(#t #t)
+ (let* ((patch (search-patch "glibc-locales.patch"))
+ (commit "f8934ec94df5868ee8baf1fb0f8ed0f24e7e91eb")
+ (t (options->transformation
+ ;; Note: options are applied in reverse order, so
+ ;; 'with-patch' comes on top.
+ `((with-patch . ,(string-append "guile-gcrypt=" patch))
+ (with-commit
+ . ,(string-append "guile-gcrypt=" commit))))))
+ (let ((new (t (@ (gnu packages gnupg) guile-gcrypt))))
+ (match (package-source new)
+ ((? computed-file? source)
+ (let* ((gexp (computed-file-gexp source))
+ (inputs (map gexp-input-thing
+ ((@@ (guix gexp) gexp-inputs) gexp))))
+ (list (any (lambda (input)
+ (and (git-checkout? input)
+ (string=? commit (git-checkout-commit input))))
+ inputs)
+ (any (lambda (input)
+ (and (local-file? input)
+ (string=? (local-file-file input) patch)))
+ inputs))))))))
+
(test-equal "options->transformation, with-latest"
"42.0"
(mock ((guix upstream) %updaters
generated by cgit v1.2.3 (git 2.50.1) at 2025-08-05 19:53:57 +0000