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
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
|
;;;; web-server.test --- HTTP server -*- mode: scheme; coding: utf-8; -*-
;;;;
;;;; Copyright (C) 2019, 2020 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite web-client)
#:use-module (web client)
#:use-module (web request)
#:use-module (web response)
#:use-module (web server)
#:use-module (web uri)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 binary-ports)
#:use-module (ice-9 match)
#:use-module (ice-9 threads)
#:use-module (srfi srfi-11)
#:use-module (test-suite lib))
(define (handle-request request body)
(match (cons (request-method request)
(split-and-decode-uri-path
(uri-path (request-uri request))))
(('GET) ;root
(values '((content-type . (text/plain (charset . "UTF-8"))))
"Hello, λ world!"))
(('GET "latin1")
(values '((content-type . (text/plain (charset . "ISO-8859-1"))))
"Écrit comme ça en Latin-1."))
(('GET "user-agent")
(values '((content-type . (text/plain)))
(lambda (port)
(display (assq-ref (request-headers request) 'user-agent)
port))))
(('GET "quit")
(values '()
(lambda (port) (pk 'quit) (throw 'quit))))
(('GET _ ...)
(values (build-response #:code 404) "not found"))
(_
(values (build-response #:code 403
#:headers
'((content-type . (application/octet-stream))))
(string->utf8 "forbidden")))))
(define %port-number 8885)
(define %server-base-uri "http://localhost:8885")
(when (provided? 'threads)
;; Run a local publishing server in a separate thread.
(call-with-new-thread
(lambda ()
(run-server handle-request 'http `(#:port ,%port-number)))))
(define-syntax-rule (expect method path code args ...)
(if (provided? 'threads)
(let-values (((response body)
(method (string-append %server-base-uri path)
#:decode-body? #t
#:keep-alive? #f args ...)))
(and (= code (response-code response))
body))
(throw 'unresolved)))
(pass-if-equal "GET /"
"Hello, λ world!"
(expect http-get "/" 200))
(pass-if-equal "GET /latin1"
"Écrit comme ça en Latin-1."
(expect http-get "/latin1" 200))
(pass-if-equal "GET /user-agent"
"GNU Guile"
(expect http-get "/user-agent" 200
#:headers `((user-agent . "GNU Guile"))))
(pass-if-equal "GET /does-not-exist"
"not found"
(expect http-get "/does-not-exist" 404))
(pass-if-equal "GET with keep-alive"
'("Hello, λ world!"
"Écrit comme ça en Latin-1."
"GNU Guile")
(if (provided? 'threads)
(let ((port (open-socket-for-uri %server-base-uri)))
(define result
(map (lambda (path)
(let-values (((response body)
(http-get (string-append %server-base-uri path)
#:port port
#:keep-alive? #t
#:headers
'((user-agent . "GNU Guile")))))
(and (= (response-code response) 200)
body)))
'("/" "/latin1" "/user-agent")))
(close-port port)
result)
(throw 'unresolved)))
(pass-if-equal "POST /"
"forbidden"
(utf8->string (expect http-post "/" 403)))
|