From 9323ab550f3bcb75fcaefbb20847595974702d5b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 29 Aug 2019 16:01:32 +0200 Subject: tests: 'with-http-server' accepts multiple responses. * guix/tests/http.scm (call-with-http-server): Replace 'code' and 'data' parameters with 'responses+data'. Compute RESPONSES as a function of that. Remove #:headers parameter. [http-write]: Quit only when RESPONSES is empty. [server-body]: Get the response and data from RESPONSES, and set it to point to the rest. (with-http-server): Adjust accordingly. * tests/derivations.scm ("'download' built-in builder") ("'download' built-in builder, invalid hash") ("'download' built-in builder, not found") ("'download' built-in builder, check mode"): Adjust to new 'with-http-server' interface. * tests/lint.scm ("home-page: 200") ("home-page: 200 but short length") ("home-page: 404", "home-page: 301, invalid"): ("home-page: 301 -> 200", "home-page: 301 -> 404") ("source: 200", "source: 200 but short length") ("source: 404", "source: 404 and 200") ("source: 301 -> 200", "source: 301 -> 404"): ("github-url", github-url): Likewise. * tests/swh.scm (with-json-result) ("lookup-origin, not found"): Likewise. --- tests/derivations.scm | 12 +++---- tests/lint.scm | 98 ++++++++++++++++++++++++++++++--------------------- tests/swh.scm | 5 +-- 3 files changed, 67 insertions(+), 48 deletions(-) (limited to 'tests') diff --git a/tests/derivations.scm b/tests/derivations.scm index db73d19b3a..00cedef32c 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -210,7 +210,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" @@ -225,7 +225,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" @@ -240,7 +240,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" @@ -275,9 +275,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) @@ -1264,5 +1264,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/lint.scm b/tests/lint.scm index db6dd6dbe1..c8b88136f4 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -390,7 +390,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 +399,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 +410,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 +420,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 +430,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 +447,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 +587,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 +599,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 +614,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 +629,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 +646,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 +668,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 +707,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 +719,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 @@ -844,6 +862,6 @@ (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..9a0da07ae1 100644 --- a/tests/swh.scm +++ b/tests/swh.scm @@ -40,7 +40,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 +56,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")))) @@ -72,5 +72,6 @@ ;; Local Variables: ;; eval: (put 'with-json-result 'scheme-indent-function 1) +;; eval: (put 'with-http-server 'scheme-indent-function 1) ;; End: -- cgit v1.2.3 From ba1c1853a79a5930ca7db7a6b368859f805df98d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 29 Aug 2019 15:59:16 +0200 Subject: swh: Add hooks for rate limiting handling. * guix/swh.scm (%allow-request?, %save-rate-limit-reset-time) (%general-rate-limit-reset-time): New variables. (request-rate-limit-reached?, update-rate-limit-reset-time!): New procedures. (call): Call '%allow-request?'. Change 'swh-error' protocol to pass METHOD in addition to URL. * tests/swh.scm ("rate limit reached") ("%allow-request? and request-rate-limit-reached?"): New tests. --- tests/swh.scm | 36 ++++++++++++++++++++++++++++++++++++ 1 file changed, 36 insertions(+) (limited to 'tests') diff --git a/tests/swh.scm b/tests/swh.scm index 9a0da07ae1..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). @@ -68,6 +69,41 @@ (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: -- cgit v1.2.3 From 55549c7b9b778a79d3e1f3d085861ef36aabdca6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 30 Aug 2019 00:54:15 +0200 Subject: lint: Add 'archival' checker. * guix/lint.scm (check-archival): New procedure. (%network-dependent-checkers): Add 'archival' checker. * tests/lint.scm ("archival: missing content") ("archival: content available") ("archival: missing revision") ("archival: revision available") ("archival: rate limit reached"): New tests. * doc/guix.texi (Invoking guix lint): Document it. --- tests/lint.scm | 81 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 81 insertions(+) (limited to 'tests') diff --git a/tests/lint.scm b/tests/lint.scm index c8b88136f4..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) @@ -859,6 +861,85 @@ '() (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: -- cgit v1.2.3 From 3c82f1254116be2a9216b7c7e5e8c001ff486270 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 4 Sep 2019 12:24:59 +0200 Subject: tests: Adjust '--with-commit' test. This is a followup to 4d04bc50d2df32be326e0f48f378dc581f873989. * tests/guix-build-branch.sh: Expect "v0.1.0" to lead to "guile-gcrypt-0.1.0". --- tests/guix-build-branch.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'tests') 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" -- cgit v1.2.3 From 2791870d09afd247a011bc8cb6cf88661729bd98 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 1 Sep 2019 16:20:36 +0200 Subject: import: crate: Separate crates.io API from actual conversion. This provides a clean separation between bindings to the https://crates.io/api/v1 API and actual conversion to Guix package sexps. As a side-effect, it fixes things like "guix import blake2-rfc", "guix refresh -t crates", etc. * guix/import/crate.scm (, , ): New record types. (lookup-crate, crate-version-dependencies): New procedures. (crate-fetch): Remove. (crate->guix-package): Rewrite to use the new API. (latest-release): Likewise. * guix/build-system/cargo.scm (%crate-base-url): New variable. * tests/crate.scm (test-crate): Update accordingly. fixlet --- tests/crate.scm | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/tests/crate.scm b/tests/crate.scm index 72c3a13350..8a232ba06c 100644 --- a/tests/crate.scm +++ b/tests/crate.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 David Thompson ;;; Copyright © 2016 David Craven +;;; Copyright © 2019 Ludovic Courtès ;;; ;;; 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/Apache-2.0\", + \"links\": { + \"dependencies\": \"/api/v1/crates/foo/1.0.0/dependencies\" + } + } + ] } }") -- cgit v1.2.3 From 191668bc9759dc87a27b5f4d55d214cc655f197f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 1 Sep 2019 16:32:11 +0200 Subject: import: crate: Correct interpretation of dual-licensing strings. * guix/import/crate.scm (%dual-license-rx): New variable. (crate->guix-package)[string->license]: Rewrite to match it. * tests/crate.scm (test-crate): Adjust "license" field to current practice. --- tests/crate.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'tests') diff --git a/tests/crate.scm b/tests/crate.scm index 8a232ba06c..c14862ad9f 100644 --- a/tests/crate.scm +++ b/tests/crate.scm @@ -41,7 +41,7 @@ \"actual_versions\": [ { \"id\": \"foo\", \"num\": \"1.0.0\", - \"license\": \"MIT/Apache-2.0\", + \"license\": \"MIT OR Apache-2.0\", \"links\": { \"dependencies\": \"/api/v1/crates/foo/1.0.0/dependencies\" } -- cgit v1.2.3