nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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.
This commit is contained in:
Ludovic Courtès 2019-08-29 16:01:32 +02:00
parent d34e9114e6
commit 9323ab550f
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
4 changed files with 91 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
guix/tests/http.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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. ;;; This file is part of GNU Guix.
;;; ;;;
@ -22,6 +22,7 @@
#:use-module (web server http) #:use-module (web server http)
#:use-module (web response) #:use-module (web response)
#:use-module (srfi srfi-39) #:use-module (srfi srfi-39)
#:use-module (ice-9 match)
#:export (with-http-server #:export (with-http-server
call-with-http-server call-with-http-server
%http-server-port %http-server-port
@ -69,10 +70,20 @@ needed."
(string-append "http://localhost:" (number->string (%http-server-port)) (string-append "http://localhost:" (number->string (%http-server-port))
"/foo/bar")) "/foo/bar"))
(define* (call-with-http-server code data thunk (define* (call-with-http-server responses+data thunk)
#:key (headers '())) "Call THUNK with an HTTP server running and returning RESPONSES+DATA on HTTP
"Call THUNK with an HTTP server running and returning CODE and DATA (a requests. Each elements of RESPONSES+DATA must be a tuple containing a
string) on HTTP requests." 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) (define (http-write server client response body)
"Write RESPONSE." "Write RESPONSE."
(let* ((response (write-response response client)) (let* ((response (write-response response client))
@ -82,7 +93,8 @@ string) on HTTP requests."
(else (else
(write-response-body response body))) (write-response-body response body)))
(close-port port) (close-port port)
(quit #t) ;exit the server thread (when (null? responses)
(quit #t)) ;exit the server thread
(values))) (values)))
;; Mutex and condition variable to synchronize with the HTTP server. ;; Mutex and condition variable to synchronize with the HTTP server.
@ -105,10 +117,10 @@ string) on HTTP requests."
(define (server-body) (define (server-body)
(define (handle request body) (define (handle request body)
(values (build-response #:code code (match responses
#:reason-phrase "Such is life" (((response data) rest ...)
#:headers headers) (set! responses rest)
data)) (values response data))))
(let ((socket (open-http-server-socket))) (let ((socket (open-http-server-socket)))
(catch 'quit (catch 'quit
@ -126,10 +138,7 @@ string) on HTTP requests."
(define-syntax with-http-server (define-syntax with-http-server
(syntax-rules () (syntax-rules ()
((_ (code headers) data body ...) ((_ responses+data body ...)
(call-with-http-server code data (lambda () body ...) (call-with-http-server responses+data (lambda () body ...)))))
#:headers headers))
((_ code data body ...)
(call-with-http-server code data (lambda () body ...)))))
;;; http.scm ends here ;;; http.scm ends here

12
tests/derivations.scm
View File

@ -210,7 +210,7 @@
(test-skip 1)) (test-skip 1))
(test-assert "'download' built-in builder" (test-assert "'download' built-in builder"
(let ((text (random-text))) (let ((text (random-text)))
(with-http-server 200 text (with-http-server `((200 ,text))
(let* ((drv (derivation %store "world" (let* ((drv (derivation %store "world"
"builtin:download" '() "builtin:download" '()
#:env-vars `(("url" #:env-vars `(("url"
@ -225,7 +225,7 @@
(unless (http-server-can-listen?) (unless (http-server-can-listen?)
(test-skip 1)) (test-skip 1))
(test-assert "'download' built-in builder, invalid hash" (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" (let* ((drv (derivation %store "world"
"builtin:download" '() "builtin:download" '()
#:env-vars `(("url" #:env-vars `(("url"
@ -240,7 +240,7 @@
(unless (http-server-can-listen?) (unless (http-server-can-listen?)
(test-skip 1)) (test-skip 1))
(test-assert "'download' built-in builder, not found" (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" (let* ((drv (derivation %store "will-never-be-found"
"builtin:download" '() "builtin:download" '()
#:env-vars `(("url" #:env-vars `(("url"
@ -275,9 +275,9 @@
. ,(object->string (%local-url)))) . ,(object->string (%local-url))))
#:hash-algo 'sha256 #:hash-algo 'sha256
#:hash (sha256 (string->utf8 text))))) #:hash (sha256 (string->utf8 text)))))
(and (with-http-server 200 text (and (with-http-server `((200 ,text))
(build-derivations %store (list drv))) (build-derivations %store (list drv)))
(with-http-server 200 text (with-http-server `((200 ,text))
(build-derivations %store (list drv) (build-derivations %store (list drv)
(build-mode check))) (build-mode check)))
(string=? (call-with-input-file (derivation->output-path drv) (string=? (call-with-input-file (derivation->output-path drv)
@ -1264,5 +1264,5 @@
(test-end) (test-end)
;; Local Variables: ;; Local Variables:
;; eval: (put 'with-http-server 'scheme-indent-function 2) ;; eval: (put 'with-http-server 'scheme-indent-function 1)
;; End: ;; End:

84
tests/lint.scm
View File

@ -390,7 +390,7 @@
(test-skip (if (http-server-can-listen?) 0 1)) (test-skip (if (http-server-can-listen?) 0 1))
(test-equal "home-page: 200" (test-equal "home-page: 200"
'() '()
(with-http-server 200 %long-string (with-http-server `((200 ,%long-string))
(let ((pkg (package (let ((pkg (package
(inherit (dummy-package "x")) (inherit (dummy-package "x"))
(home-page (%local-url))))) (home-page (%local-url)))))
@ -399,7 +399,7 @@
(test-skip (if (http-server-can-listen?) 0 1)) (test-skip (if (http-server-can-listen?) 0 1))
(test-equal "home-page: 200 but short length" (test-equal "home-page: 200 but short length"
"URI http://localhost:9999/foo/bar returned suspiciously small file (18 bytes)" "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 (let ((pkg (package
(inherit (dummy-package "x")) (inherit (dummy-package "x"))
(home-page (%local-url))))) (home-page (%local-url)))))
@ -410,7 +410,7 @@
(test-skip (if (http-server-can-listen?) 0 1)) (test-skip (if (http-server-can-listen?) 0 1))
(test-equal "home-page: 404" (test-equal "home-page: 404"
"URI http://localhost:9999/foo/bar not reachable: 404 (\"Such is life\")" "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 (let ((pkg (package
(inherit (dummy-package "x")) (inherit (dummy-package "x"))
(home-page (%local-url))))) (home-page (%local-url)))))
@ -420,7 +420,7 @@
(test-skip (if (http-server-can-listen?) 0 1)) (test-skip (if (http-server-can-listen?) 0 1))
(test-equal "home-page: 301, invalid" (test-equal "home-page: 301, invalid"
"invalid permanent redirect from http://localhost:9999/foo/bar" "invalid permanent redirect from http://localhost:9999/foo/bar"
(with-http-server 301 %long-string (with-http-server `((301 ,%long-string))
(let ((pkg (package (let ((pkg (package
(inherit (dummy-package "x")) (inherit (dummy-package "x"))
(home-page (%local-url))))) (home-page (%local-url)))))
@ -430,12 +430,14 @@
(test-skip (if (http-server-can-listen?) 0 1)) (test-skip (if (http-server-can-listen?) 0 1))
(test-equal "home-page: 301 -> 200" (test-equal "home-page: 301 -> 200"
"permanent redirect from http://localhost:10000/foo/bar to http://localhost:9999/foo/bar" "permanent redirect from http://localhost:10000/foo/bar to http://localhost:9999/foo/bar"
(with-http-server 200 %long-string (with-http-server `((200 ,%long-string))
(let ((initial-url (%local-url))) (let* ((initial-url (%local-url))
(redirect (build-response #:code 301
#:headers
`((location
. ,(string->uri initial-url))))))
(parameterize ((%http-server-port (+ 1 (%http-server-port)))) (parameterize ((%http-server-port (+ 1 (%http-server-port))))
(with-http-server (301 `((location (with-http-server `((,redirect ""))
. ,(string->uri initial-url))))
""
(let ((pkg (package (let ((pkg (package
(inherit (dummy-package "x")) (inherit (dummy-package "x"))
(home-page (%local-url))))) (home-page (%local-url)))))
@ -445,12 +447,14 @@
(test-skip (if (http-server-can-listen?) 0 1)) (test-skip (if (http-server-can-listen?) 0 1))
(test-equal "home-page: 301 -> 404" (test-equal "home-page: 301 -> 404"
"URI http://localhost:10000/foo/bar not reachable: 404 (\"Such is life\")" "URI http://localhost:10000/foo/bar not reachable: 404 (\"Such is life\")"
(with-http-server 404 "booh!" (with-http-server '((404 "booh!"))
(let ((initial-url (%local-url))) (let* ((initial-url (%local-url))
(redirect (build-response #:code 301
#:headers
`((location
. ,(string->uri initial-url))))))
(parameterize ((%http-server-port (+ 1 (%http-server-port)))) (parameterize ((%http-server-port (+ 1 (%http-server-port))))
(with-http-server (301 `((location (with-http-server `((,redirect ""))
. ,(string->uri initial-url))))
""
(let ((pkg (package (let ((pkg (package
(inherit (dummy-package "x")) (inherit (dummy-package "x"))
(home-page (%local-url))))) (home-page (%local-url)))))
@ -583,7 +587,7 @@
(test-skip (if (http-server-can-listen?) 0 1)) (test-skip (if (http-server-can-listen?) 0 1))
(test-equal "source: 200" (test-equal "source: 200"
'() '()
(with-http-server 200 %long-string (with-http-server `((200 ,%long-string))
(let ((pkg (package (let ((pkg (package
(inherit (dummy-package "x")) (inherit (dummy-package "x"))
(source (origin (source (origin
@ -595,7 +599,7 @@
(test-skip (if (http-server-can-listen?) 0 1)) (test-skip (if (http-server-can-listen?) 0 1))
(test-equal "source: 200 but short length" (test-equal "source: 200 but short length"
"URI http://localhost:9999/foo/bar returned suspiciously small file (18 bytes)" "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 (let ((pkg (package
(inherit (dummy-package "x")) (inherit (dummy-package "x"))
(source (origin (source (origin
@ -610,7 +614,7 @@
(test-skip (if (http-server-can-listen?) 0 1)) (test-skip (if (http-server-can-listen?) 0 1))
(test-equal "source: 404" (test-equal "source: 404"
"URI http://localhost:9999/foo/bar not reachable: 404 (\"Such is life\")" "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 (let ((pkg (package
(inherit (dummy-package "x")) (inherit (dummy-package "x"))
(source (origin (source (origin
@ -625,10 +629,10 @@
(test-skip (if (http-server-can-listen?) 0 1)) (test-skip (if (http-server-can-listen?) 0 1))
(test-equal "source: 404 and 200" (test-equal "source: 404 and 200"
'() '()
(with-http-server 404 %long-string (with-http-server `((404 ,%long-string))
(let ((bad-url (%local-url))) (let ((bad-url (%local-url)))
(parameterize ((%http-server-port (+ 1 (%http-server-port)))) (parameterize ((%http-server-port (+ 1 (%http-server-port))))
(with-http-server 200 %long-string (with-http-server `((200 ,%long-string))
(let ((pkg (package (let ((pkg (package
(inherit (dummy-package "x")) (inherit (dummy-package "x"))
(source (origin (source (origin
@ -642,11 +646,14 @@
(test-skip (if (http-server-can-listen?) 0 1)) (test-skip (if (http-server-can-listen?) 0 1))
(test-equal "source: 301 -> 200" (test-equal "source: 301 -> 200"
"permanent redirect from http://localhost:10000/foo/bar to http://localhost:9999/foo/bar" "permanent redirect from http://localhost:10000/foo/bar to http://localhost:9999/foo/bar"
(with-http-server 200 %long-string (with-http-server `((200 ,%long-string))
(let ((initial-url (%local-url))) (let* ((initial-url (%local-url))
(redirect (build-response #:code 301
#:headers
`((location
. ,(string->uri initial-url))))))
(parameterize ((%http-server-port (+ 1 (%http-server-port)))) (parameterize ((%http-server-port (+ 1 (%http-server-port))))
(with-http-server (301 `((location . ,(string->uri initial-url)))) (with-http-server `((,redirect ""))
""
(let ((pkg (package (let ((pkg (package
(inherit (dummy-package "x")) (inherit (dummy-package "x"))
(source (origin (source (origin
@ -661,11 +668,14 @@
(test-skip (if (http-server-can-listen?) 0 1)) (test-skip (if (http-server-can-listen?) 0 1))
(test-equal "source: 301 -> 404" (test-equal "source: 301 -> 404"
"URI http://localhost:10000/foo/bar not reachable: 404 (\"Such is life\")" "URI http://localhost:10000/foo/bar not reachable: 404 (\"Such is life\")"
(with-http-server 404 "booh!" (with-http-server '((404 "booh!"))
(let ((initial-url (%local-url))) (let* ((initial-url (%local-url))
(redirect (build-response #:code 301
#:headers
`((location
. ,(string->uri initial-url))))))
(parameterize ((%http-server-port (+ 1 (%http-server-port)))) (parameterize ((%http-server-port (+ 1 (%http-server-port))))
(with-http-server (301 `((location . ,(string->uri initial-url)))) (with-http-server `((,redirect ""))
""
(let ((pkg (package (let ((pkg (package
(inherit (dummy-package "x")) (inherit (dummy-package "x"))
(source (origin (source (origin
@ -697,7 +707,7 @@
(test-equal "github-url" (test-equal "github-url"
'() '()
(with-http-server 200 %long-string (with-http-server `((200 ,%long-string))
(check-github-url (check-github-url
(dummy-package "x" (source (dummy-package "x" (source
(origin (origin
@ -709,17 +719,25 @@
(test-equal "github-url: one suggestion" (test-equal "github-url: one suggestion"
(string-append (string-append
"URL should be '" github-url "'") "URL should be '" github-url "'")
(with-http-server (301 `((location . ,(string->uri github-url)))) "" (let ((redirect (build-response #:code 301
(let ((initial-uri (%local-url))) #: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)))) (parameterize ((%http-server-port (+ 1 (%http-server-port))))
(with-http-server (302 `((location . ,(string->uri initial-uri)))) "" (with-http-server `((,redirect ""))
(single-lint-warning-message (single-lint-warning-message
(check-github-url (check-github-url
(dummy-package "x" (source (dummy-package "x" (source
(origin (origin
(method url-fetch) (method url-fetch)
(uri (%local-url)) (uri (%local-url))
(sha256 %null-sha256))))))))))) (sha256 %null-sha256))))))))))))
(test-equal "github-url: already the correct github url" (test-equal "github-url: already the correct github url"
'() '()
(check-github-url (check-github-url
@ -844,6 +862,6 @@
(test-end "lint") (test-end "lint")
;; Local Variables: ;; 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) ;; eval: (put 'with-warnings 'scheme-indent-function 0)
;; End: ;; End:

5
tests/swh.scm
View File

@ -40,7 +40,7 @@
\"dir_id\": 2 } ]") \"dir_id\": 2 } ]")
(define-syntax-rule (with-json-result str exp ...) (define-syntax-rule (with-json-result str exp ...)
(with-http-server 200 str (with-http-server `((200 ,str))
(parameterize ((%swh-base-url (%local-url))) (parameterize ((%swh-base-url (%local-url)))
exp ...))) exp ...)))
@ -56,7 +56,7 @@
(test-equal "lookup-origin, not found" (test-equal "lookup-origin, not found"
#f #f
(with-http-server 404 "Nope." (with-http-server `((404 "Nope."))
(parameterize ((%swh-base-url (%local-url))) (parameterize ((%swh-base-url (%local-url)))
(lookup-origin "http://example.org/whatever")))) (lookup-origin "http://example.org/whatever"))))
@ -72,5 +72,6 @@
;; Local Variables: ;; Local Variables:
;; eval: (put 'with-json-result 'scheme-indent-function 1) ;; eval: (put 'with-json-result 'scheme-indent-function 1)
;; eval: (put 'with-http-server 'scheme-indent-function 1)
;; End: ;; End: