tests: Add (web server) test.

* test-suite/tests/web-server.test: New file.
* test-suite/Makefile.am (SCM_TESTS): Add it.

2 files changed, 119 insertions, 0 deletions

diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 0934dbb34..e15b92aff 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -196,6 +196,7 @@ SCM_TESTS = tests/00-initial-env.test		\
 	    tests/web-http.test			\
 	    tests/web-request.test		\
 	    tests/web-response.test		\
+	    tests/web-server.test		\
 	    tests/web-uri.test
 
 EXTRA_DIST = \
diff --git a/test-suite/tests/web-server.test b/test-suite/tests/web-server.test
new file mode 100644
index 000000000..e2a563499
--- /dev/null
+++ b/test-suite/tests/web-server.test
@@ -0,0 +1,118 @@
+;;;; 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)))