guile/test-suite/tests/web-server.test

;;;; 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)))