aboutsummaryrefslogtreecommitdiff
path: root/tests
diff options
context:
space:
mode:
authorMark H Weaver <mhw@netris.org>2019-09-06 20:46:00 -0400
committerMark H Weaver <mhw@netris.org>2019-09-06 20:46:00 -0400
commit65542a8852759f35e19959149ac92297c8b54be5 (patch)
treebc8f398c7b10a4725b20aa59ab1452d30f358ea3 /tests
parentbc60349b5bc58a0b803df5adce1de6db82453744 (diff)
parentf66aee3d0d2f573187ed5d44ae7c13d73cd4097a (diff)
downloadguix-65542a8852759f35e19959149ac92297c8b54be5.tar
guix-65542a8852759f35e19959149ac92297c8b54be5.tar.gz
Merge branch 'master' into core-updates
Diffstat (limited to 'tests')
-rw-r--r--tests/crate.scm13
-rw-r--r--tests/derivations.scm12
-rw-r--r--tests/guix-build-branch.sh2
-rw-r--r--tests/lint.scm179
-rw-r--r--tests/swh.scm41
5 files changed, 197 insertions, 50 deletions
diff --git a/tests/crate.scm b/tests/crate.scm
index 72c3a13350..c14862ad9f 100644
--- a/tests/crate.scm
+++ b/tests/crate.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 David Thompson <davet@gnu.org>
;;; Copyright © 2016 David Craven <david@craven.ch>
+;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -32,10 +33,20 @@
\"crate\": {
\"max_version\": \"1.0.0\",
\"name\": \"foo\",
- \"license\": \"MIT/Apache-2.0\",
\"description\": \"summary\",
\"homepage\": \"http://example.com\",
\"repository\": \"http://example.com\",
+ \"keywords\": [\"dummy\" \"test\"],
+ \"categories\": [\"test\"]
+ \"actual_versions\": [
+ { \"id\": \"foo\",
+ \"num\": \"1.0.0\",
+ \"license\": \"MIT OR Apache-2.0\",
+ \"links\": {
+ \"dependencies\": \"/api/v1/crates/foo/1.0.0/dependencies\"
+ }
+ }
+ ]
}
}")
diff --git a/tests/derivations.scm b/tests/derivations.scm
index 56b2775248..6a7fad85b5 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -209,7 +209,7 @@
(test-skip 1))
(test-assert "'download' built-in builder"
(let ((text (random-text)))
- (with-http-server 200 text
+ (with-http-server `((200 ,text))
(let* ((drv (derivation %store "world"
"builtin:download" '()
#:env-vars `(("url"
@@ -224,7 +224,7 @@
(unless (http-server-can-listen?)
(test-skip 1))
(test-assert "'download' built-in builder, invalid hash"
- (with-http-server 200 "hello, world!"
+ (with-http-server `((200 "hello, world!"))
(let* ((drv (derivation %store "world"
"builtin:download" '()
#:env-vars `(("url"
@@ -239,7 +239,7 @@
(unless (http-server-can-listen?)
(test-skip 1))
(test-assert "'download' built-in builder, not found"
- (with-http-server 404 "not found"
+ (with-http-server '((404 "not found"))
(let* ((drv (derivation %store "will-never-be-found"
"builtin:download" '()
#:env-vars `(("url"
@@ -274,9 +274,9 @@
. ,(object->string (%local-url))))
#:hash-algo 'sha256
#:hash (sha256 (string->utf8 text)))))
- (and (with-http-server 200 text
+ (and (with-http-server `((200 ,text))
(build-derivations %store (list drv)))
- (with-http-server 200 text
+ (with-http-server `((200 ,text))
(build-derivations %store (list drv)
(build-mode check)))
(string=? (call-with-input-file (derivation->output-path drv)
@@ -1263,5 +1263,5 @@
(test-end)
;; Local Variables:
-;; eval: (put 'with-http-server 'scheme-indent-function 2)
+;; eval: (put 'with-http-server 'scheme-indent-function 1)
;; End:
diff --git a/tests/guix-build-branch.sh b/tests/guix-build-branch.sh
index 3d2a7dddf5..2556a0cdb9 100644
--- a/tests/guix-build-branch.sh
+++ b/tests/guix-build-branch.sh
@@ -53,7 +53,7 @@ test "$v0_1_0_drv" != "$latest_drv"
test "$v0_1_0_drv" != "$orig_drv"
v0_1_0_drv="`guix build guix --with-commit=guile-gcrypt=v0.1.0 -d`"
-guix gc -R "$v0_1_0_drv" | grep guile-gcrypt-git.v0.1.0
+guix gc -R "$v0_1_0_drv" | grep guile-gcrypt-0.1.0
guix gc -R "$v0_1_0_drv" | grep guile-gcrypt-9e3eacd
test "$v0_1_0_drv" != "$latest_drv"
test "$v0_1_0_drv" != "$orig_drv"
diff --git a/tests/lint.scm b/tests/lint.scm
index db6dd6dbe1..1b92f02b85 100644
--- a/tests/lint.scm
+++ b/tests/lint.scm
@@ -35,6 +35,7 @@
#:use-module (guix packages)
#:use-module (guix lint)
#:use-module (guix ui)
+ #:use-module (guix swh)
#:use-module (gnu packages)
#:use-module (gnu packages glib)
#:use-module (gnu packages pkg-config)
@@ -47,6 +48,7 @@
#:use-module (ice-9 regex)
#:use-module (ice-9 getopt-long)
#:use-module (ice-9 pretty-print)
+ #:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-26)
@@ -390,7 +392,7 @@
(test-skip (if (http-server-can-listen?) 0 1))
(test-equal "home-page: 200"
'()
- (with-http-server 200 %long-string
+ (with-http-server `((200 ,%long-string))
(let ((pkg (package
(inherit (dummy-package "x"))
(home-page (%local-url)))))
@@ -399,7 +401,7 @@
(test-skip (if (http-server-can-listen?) 0 1))
(test-equal "home-page: 200 but short length"
"URI http://localhost:9999/foo/bar returned suspiciously small file (18 bytes)"
- (with-http-server 200 "This is too small."
+ (with-http-server `((200 "This is too small."))
(let ((pkg (package
(inherit (dummy-package "x"))
(home-page (%local-url)))))
@@ -410,7 +412,7 @@
(test-skip (if (http-server-can-listen?) 0 1))
(test-equal "home-page: 404"
"URI http://localhost:9999/foo/bar not reachable: 404 (\"Such is life\")"
- (with-http-server 404 %long-string
+ (with-http-server `((404 ,%long-string))
(let ((pkg (package
(inherit (dummy-package "x"))
(home-page (%local-url)))))
@@ -420,7 +422,7 @@
(test-skip (if (http-server-can-listen?) 0 1))
(test-equal "home-page: 301, invalid"
"invalid permanent redirect from http://localhost:9999/foo/bar"
- (with-http-server 301 %long-string
+ (with-http-server `((301 ,%long-string))
(let ((pkg (package
(inherit (dummy-package "x"))
(home-page (%local-url)))))
@@ -430,12 +432,14 @@
(test-skip (if (http-server-can-listen?) 0 1))
(test-equal "home-page: 301 -> 200"
"permanent redirect from http://localhost:10000/foo/bar to http://localhost:9999/foo/bar"
- (with-http-server 200 %long-string
- (let ((initial-url (%local-url)))
+ (with-http-server `((200 ,%long-string))
+ (let* ((initial-url (%local-url))
+ (redirect (build-response #:code 301
+ #:headers
+ `((location
+ . ,(string->uri initial-url))))))
(parameterize ((%http-server-port (+ 1 (%http-server-port))))
- (with-http-server (301 `((location
- . ,(string->uri initial-url))))
- ""
+ (with-http-server `((,redirect ""))
(let ((pkg (package
(inherit (dummy-package "x"))
(home-page (%local-url)))))
@@ -445,12 +449,14 @@
(test-skip (if (http-server-can-listen?) 0 1))
(test-equal "home-page: 301 -> 404"
"URI http://localhost:10000/foo/bar not reachable: 404 (\"Such is life\")"
- (with-http-server 404 "booh!"
- (let ((initial-url (%local-url)))
+ (with-http-server '((404 "booh!"))
+ (let* ((initial-url (%local-url))
+ (redirect (build-response #:code 301
+ #:headers
+ `((location
+ . ,(string->uri initial-url))))))
(parameterize ((%http-server-port (+ 1 (%http-server-port))))
- (with-http-server (301 `((location
- . ,(string->uri initial-url))))
- ""
+ (with-http-server `((,redirect ""))
(let ((pkg (package
(inherit (dummy-package "x"))
(home-page (%local-url)))))
@@ -583,7 +589,7 @@
(test-skip (if (http-server-can-listen?) 0 1))
(test-equal "source: 200"
'()
- (with-http-server 200 %long-string
+ (with-http-server `((200 ,%long-string))
(let ((pkg (package
(inherit (dummy-package "x"))
(source (origin
@@ -595,7 +601,7 @@
(test-skip (if (http-server-can-listen?) 0 1))
(test-equal "source: 200 but short length"
"URI http://localhost:9999/foo/bar returned suspiciously small file (18 bytes)"
- (with-http-server 200 "This is too small."
+ (with-http-server '((200 "This is too small."))
(let ((pkg (package
(inherit (dummy-package "x"))
(source (origin
@@ -610,7 +616,7 @@
(test-skip (if (http-server-can-listen?) 0 1))
(test-equal "source: 404"
"URI http://localhost:9999/foo/bar not reachable: 404 (\"Such is life\")"
- (with-http-server 404 %long-string
+ (with-http-server `((404 ,%long-string))
(let ((pkg (package
(inherit (dummy-package "x"))
(source (origin
@@ -625,10 +631,10 @@
(test-skip (if (http-server-can-listen?) 0 1))
(test-equal "source: 404 and 200"
'()
- (with-http-server 404 %long-string
+ (with-http-server `((404 ,%long-string))
(let ((bad-url (%local-url)))
(parameterize ((%http-server-port (+ 1 (%http-server-port))))
- (with-http-server 200 %long-string
+ (with-http-server `((200 ,%long-string))
(let ((pkg (package
(inherit (dummy-package "x"))
(source (origin
@@ -642,11 +648,14 @@
(test-skip (if (http-server-can-listen?) 0 1))
(test-equal "source: 301 -> 200"
"permanent redirect from http://localhost:10000/foo/bar to http://localhost:9999/foo/bar"
- (with-http-server 200 %long-string
- (let ((initial-url (%local-url)))
+ (with-http-server `((200 ,%long-string))
+ (let* ((initial-url (%local-url))
+ (redirect (build-response #:code 301
+ #:headers
+ `((location
+ . ,(string->uri initial-url))))))
(parameterize ((%http-server-port (+ 1 (%http-server-port))))
- (with-http-server (301 `((location . ,(string->uri initial-url))))
- ""
+ (with-http-server `((,redirect ""))
(let ((pkg (package
(inherit (dummy-package "x"))
(source (origin
@@ -661,11 +670,14 @@
(test-skip (if (http-server-can-listen?) 0 1))
(test-equal "source: 301 -> 404"
"URI http://localhost:10000/foo/bar not reachable: 404 (\"Such is life\")"
- (with-http-server 404 "booh!"
- (let ((initial-url (%local-url)))
+ (with-http-server '((404 "booh!"))
+ (let* ((initial-url (%local-url))
+ (redirect (build-response #:code 301
+ #:headers
+ `((location
+ . ,(string->uri initial-url))))))
(parameterize ((%http-server-port (+ 1 (%http-server-port))))
- (with-http-server (301 `((location . ,(string->uri initial-url))))
- ""
+ (with-http-server `((,redirect ""))
(let ((pkg (package
(inherit (dummy-package "x"))
(source (origin
@@ -697,7 +709,7 @@
(test-equal "github-url"
'()
- (with-http-server 200 %long-string
+ (with-http-server `((200 ,%long-string))
(check-github-url
(dummy-package "x" (source
(origin
@@ -709,17 +721,25 @@
(test-equal "github-url: one suggestion"
(string-append
"URL should be '" github-url "'")
- (with-http-server (301 `((location . ,(string->uri github-url)))) ""
- (let ((initial-uri (%local-url)))
- (parameterize ((%http-server-port (+ 1 (%http-server-port))))
- (with-http-server (302 `((location . ,(string->uri initial-uri)))) ""
- (single-lint-warning-message
- (check-github-url
- (dummy-package "x" (source
- (origin
- (method url-fetch)
- (uri (%local-url))
- (sha256 %null-sha256)))))))))))
+ (let ((redirect (build-response #:code 301
+ #:headers
+ `((location
+ . ,(string->uri github-url))))))
+ (with-http-server `((,redirect ""))
+ (let* ((initial-url (%local-url))
+ (redirect (build-response #:code 302
+ #:headers
+ `((location
+ . ,(string->uri initial-url))))))
+ (parameterize ((%http-server-port (+ 1 (%http-server-port))))
+ (with-http-server `((,redirect ""))
+ (single-lint-warning-message
+ (check-github-url
+ (dummy-package "x" (source
+ (origin
+ (method url-fetch)
+ (uri (%local-url))
+ (sha256 %null-sha256))))))))))))
(test-equal "github-url: already the correct github url"
'()
(check-github-url
@@ -841,9 +861,88 @@
'()
(check-formatting (dummy-package "x")))
+(test-assert "archival: missing content"
+ (let* ((origin (origin
+ (method url-fetch)
+ (uri "http://example.org/foo.tgz")
+ (sha256 (make-bytevector 32))))
+ (warnings (with-http-server '((404 "Not archived."))
+ (parameterize ((%swh-base-url (%local-url)))
+ (check-archival (dummy-package "x"
+ (source origin)))))))
+ (warning-contains? "not archived" warnings)))
+
+(test-equal "archival: content available"
+ '()
+ (let* ((origin (origin
+ (method url-fetch)
+ (uri "http://example.org/foo.tgz")
+ (sha256 (make-bytevector 32))))
+ ;; https://archive.softwareheritage.org/api/1/content/
+ (content "{ \"checksums\": {}, \"data_url\": \"xyz\",
+ \"length\": 42 }"))
+ (with-http-server `((200 ,content))
+ (parameterize ((%swh-base-url (%local-url)))
+ (check-archival (dummy-package "x" (source origin)))))))
+
+(test-assert "archival: missing revision"
+ (let* ((origin (origin
+ (method git-fetch)
+ (uri (git-reference
+ (url "http://example.org/foo.git")
+ (commit "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")))
+ (sha256 (make-bytevector 32))))
+ ;; https://archive.softwareheritage.org/api/1/origin/save/
+ (save "{ \"origin_url\": \"http://example.org/foo.git\",
+ \"save_request_date\": \"2014-11-17T22:09:38+01:00\",
+ \"save_request_status\": \"accepted\",
+ \"save_task_status\": \"scheduled\" }")
+ (warnings (with-http-server `((404 "No revision.") ;lookup-revision
+ (404 "No origin.") ;lookup-origin
+ (200 ,save)) ;save-origin
+ (parameterize ((%swh-base-url (%local-url)))
+ (check-archival (dummy-package "x" (source origin)))))))
+ (warning-contains? "scheduled" warnings)))
+
+(test-equal "archival: revision available"
+ '()
+ (let* ((origin (origin
+ (method git-fetch)
+ (uri (git-reference
+ (url "http://example.org/foo.git")
+ (commit "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")))
+ (sha256 (make-bytevector 32))))
+ ;; https://archive.softwareheritage.org/api/1/revision/
+ (revision "{ \"author\": {}, \"parents\": [],
+ \"date\": \"2014-11-17T22:09:38+01:00\" }"))
+ (with-http-server `((200 ,revision))
+ (parameterize ((%swh-base-url (%local-url)))
+ (check-archival (dummy-package "x" (source origin)))))))
+
+(test-assert "archival: rate limit reached"
+ ;; We should get a single warning stating that the rate limit was reached,
+ ;; and nothing more, in particular no other HTTP requests.
+ (let* ((origin (origin
+ (method url-fetch)
+ (uri "http://example.org/foo.tgz")
+ (sha256 (make-bytevector 32))))
+ (too-many (build-response
+ #:code 429
+ #:reason-phrase "Too many requests"
+ #:headers '((x-ratelimit-remaining . "0")
+ (x-ratelimit-reset . "3000000000"))))
+ (warnings (with-http-server `((,too-many "Rate limit reached."))
+ (parameterize ((%swh-base-url (%local-url)))
+ (append-map (lambda (name)
+ (check-archival
+ (dummy-package name (source origin))))
+ '("x" "y" "z"))))))
+ (string-contains (single-lint-warning-message warnings)
+ "rate limit reached")))
+
(test-end "lint")
;; Local Variables:
-;; eval: (put 'with-http-server 'scheme-indent-function 2)
+;; eval: (put 'with-http-server 'scheme-indent-function 1)
;; eval: (put 'with-warnings 'scheme-indent-function 0)
;; End:
diff --git a/tests/swh.scm b/tests/swh.scm
index 07f0fda37b..e36c54e5fb 100644
--- a/tests/swh.scm
+++ b/tests/swh.scm
@@ -19,6 +19,7 @@
(define-module (test-swh)
#:use-module (guix swh)
#:use-module (guix tests http)
+ #:use-module (web response)
#:use-module (srfi srfi-64))
;; Test the JSON mapping machinery used in (guix swh).
@@ -40,7 +41,7 @@
\"dir_id\": 2 } ]")
(define-syntax-rule (with-json-result str exp ...)
- (with-http-server 200 str
+ (with-http-server `((200 ,str))
(parameterize ((%swh-base-url (%local-url)))
exp ...)))
@@ -56,7 +57,7 @@
(test-equal "lookup-origin, not found"
#f
- (with-http-server 404 "Nope."
+ (with-http-server `((404 "Nope."))
(parameterize ((%swh-base-url (%local-url)))
(lookup-origin "http://example.org/whatever"))))
@@ -68,9 +69,45 @@
(directory-entry-length entry)))
(lookup-directory "123"))))
+(test-equal "rate limit reached"
+ 3000000000
+ (let ((too-many (build-response
+ #:code 429
+ #:reason-phrase "Too many requests"
+
+ ;; Pretend we've reached the limit and it'll be reset in
+ ;; June 2065.
+ #:headers '((x-ratelimit-remaining . "0")
+ (x-ratelimit-reset . "3000000000")))))
+ (with-http-server `((,too-many "Too bad."))
+ (parameterize ((%swh-base-url (%local-url)))
+ (catch 'swh-error
+ (lambda ()
+ (lookup-origin "http://example.org/guix.git"))
+ (lambda (key url method response)
+ ;; Ensure the reset time was recorded.
+ (@@ (guix swh) %general-rate-limit-reset-time)))))))
+
+(test-assert "%allow-request? and request-rate-limit-reached?"
+ ;; Here we test two things: that the rate limit set above is in effect and
+ ;; that %ALLOW-REQUEST? is called, and that 'request-rate-limit-reached?'
+ ;; returns true.
+ (let* ((key (gensym "skip-request"))
+ (skip-if-limit-reached
+ (lambda (url method)
+ (or (not (request-rate-limit-reached? url method))
+ (throw key #t)))))
+ (parameterize ((%allow-request? skip-if-limit-reached))
+ (catch key
+ (lambda ()
+ (lookup-origin "http://example.org/guix.git")
+ #f)
+ (const #t)))))
+
(test-end "swh")
;; Local Variables:
;; eval: (put 'with-json-result 'scheme-indent-function 1)
+;; eval: (put 'with-http-server 'scheme-indent-function 1)
;; End: