blob: 837ca3abeeea44a128d93ac1f55831da5a20924f (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
|
;;; Commentary:
;; Checks that HTTP server can start correctly, and that at least some
;; endpoints return correct information.
;;
;; NOTE This test, when ran in as `tests/run-tests --only web-server.scm'
;; segfaults on Guile 2.2.7, but not on Guile 3.0.8. This doesn't happen
;; when it's run as one of all tests.
;;; Code:
(((calp server routes) make-make-routes)
((web server) run-server)
((ice-9 threads) call-with-new-thread cancel-thread)
((web client) http-get)
((hnh util) let*)
((web response) response-code response-location)
((web uri) build-uri uri-path)
((guile)
socket inet-pton bind make-socket-address setsockopt
AF_INET PF_INET SOL_SOCKET SO_REUSEADDR SOCK_STREAM
)
)
(define host "127.8.9.5")
(define sock (socket PF_INET SOCK_STREAM 0))
(setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
(define-values (port sock)
(let ((addr (inet-pton AF_INET host)))
(let loop ((port 8090))
(catch 'system-error
(lambda ()
(bind sock (make-socket-address AF_INET addr port))
(values port sock))
(lambda (err proc fmt args data)
(if (and (not (null? data))
;; errno address already in use
(= 98 (car data)))
(loop (1+ port))
;; rethrow
(throw err fmt args data)))))))
(define server-thread
(call-with-new-thread
(lambda ()
(run-server (make-make-routes) 'http `(socket: ,sock))
;; This test should always fail, but should never be run
(test-assert "Server returned unexpectedly" #f))))
(let* ((response body (http-get (build-uri 'http host: host port: port))))
(test-eqv "Basic connect" 200 (response-code response)))
(let* ((response body (http-get (build-uri 'http host: host port: port
path: "/today"
query: "view=week&date=2020-01-04"))))
(test-eqv "Redirect"
302 (response-code response))
(test-equal "Fully specified redirect position"
"/week/2020-01-04.html" (uri-path (response-location response))))
(cancel-thread server-thread)
|
