diff options
| -rw-r--r-- | guix/tests/http.scm | 39 | ||||
| -rw-r--r-- | tests/derivations.scm | 12 | ||||
| -rw-r--r-- | tests/lint.scm | 98 | ||||
| -rw-r--r-- | tests/swh.scm | 5 |
4 files changed, 91 insertions, 63 deletions
diff --git a/guix/tests/http.scm b/guix/tests/http.scm index a56d6f213d..05ce39bca2 100644 --- a/guix/tests/http.scm +++ b/guix/tests/http.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,6 +22,7 @@ #:use-module (web server http) #:use-module (web response) #:use-module (srfi srfi-39) + #:use-module (ice-9 match) #:export (with-http-server call-with-http-server %http-server-port @@ -69,10 +70,20 @@ needed." (string-append "http://localhost:" (number->string (%http-server-port)) "/foo/bar")) -(define* (call-with-http-server code data thunk - #:key (headers '())) - "Call THUNK with an HTTP server running and returning CODE and DATA (a -string) on HTTP requests." +(define* (call-with-http-server responses+data thunk) + "Call THUNK with an HTTP server running and returning RESPONSES+DATA on HTTP +requests. Each elements of RESPONSES+DATA must be a tuple containing a +response and a string, or an HTTP response code and a string." + (define responses + (map (match-lambda + (((? response? response) data) + (list response data)) + (((? integer? code) data) + (list (build-response #:code code + #:reason-phrase "Such is life") + data))) + responses+data)) + (define (http-write server client response body) "Write RESPONSE." (let* ((response (write-response response client)) @@ -82,7 +93,8 @@ string) on HTTP requests." (else (write-response-body response body))) (close-port port) - (quit #t) ;exit the server thread + (when (null? responses) + (quit #t)) ;exit the server thread (values))) ;; Mutex and condition variable to synchronize with the HTTP server. @@ -105,10 +117,10 @@ string) on HTTP requests." (define (server-body) (define (handle request body) - (values (build-response #:code code - #:reason-phrase "Such is life" - #:headers headers) - data)) + (match responses + (((response data) rest ...) + (set! responses rest) + (values response data)))) (let ((socket (open-http-server-socket))) (catch 'quit @@ -126,10 +138,7 @@ string) on HTTP requests." (define-syntax with-http-server (syntax-rules () - ((_ (code headers) data body ...) - (call-with-http-server code data (lambda () body ...) - #:headers headers)) - ((_ code data body ...) - (call-with-http-server code data (lambda () body ...))))) + ((_ responses+data body ...) + (call-with-http-server responses+data (lambda () body ...))))) ;;; http.scm ends here 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: |