mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 20:00:19 +02:00
a152a67d38
* test-suite/tests/web-server.test: New file. * test-suite/Makefile.am (SCM_TESTS): Add it.
118 lines
4.2 KiB
Scheme
118 lines
4.2 KiB
Scheme
;;;; web-server.test --- HTTP server -*- mode: scheme; coding: utf-8; -*-
|
||
;;;;
|
||
;;;; Copyright (C) 2019 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)))
|
||
|
||
(pass-if-equal "POST /"
|
||
"forbidden"
|
||
(utf8->string (expect http-post "/" 403)))
|