Christopher Baines
4642f7c7d2
Rather than raising an exception when there's a body provided, use the body as normal to inform the headers, as this is useful, and just don't write the body to the client.
301 lines
9.4 KiB
Scheme
301 lines
9.4 KiB
Scheme
(use-modules (srfi srfi-71)
|
|
(rnrs bytevectors)
|
|
(ice-9 match)
|
|
(ice-9 binary-ports)
|
|
(ice-9 textual-ports)
|
|
(tests)
|
|
(fibers)
|
|
(fibers channels)
|
|
(unit-test)
|
|
(web uri)
|
|
(web client)
|
|
(web request)
|
|
(web response)
|
|
(knots web-server)
|
|
(knots non-blocking))
|
|
|
|
(run-fibers-for-tests
|
|
(lambda ()
|
|
(let* ((web-server
|
|
(run-knots-web-server
|
|
(lambda (request)
|
|
(values '((content-type . (text/plain)))
|
|
"Hello, World!"))
|
|
#:port 0)) ;; Bind to any port
|
|
(port
|
|
(web-server-port web-server))
|
|
(uri
|
|
(build-uri 'http #:host "127.0.0.1" #:port port)))
|
|
|
|
(assert-equal
|
|
200
|
|
(response-code
|
|
(http-get
|
|
uri
|
|
#:port (non-blocking-open-socket-for-uri uri)))))))
|
|
|
|
(run-fibers-for-tests
|
|
(lambda ()
|
|
(let* ((web-server
|
|
(run-knots-web-server
|
|
(lambda (request)
|
|
"Hello, World!")
|
|
#:port 0)) ;; Bind to any port
|
|
(port
|
|
(web-server-port web-server))
|
|
(uri
|
|
(build-uri 'http #:host "127.0.0.1" #:port port)))
|
|
|
|
(assert-equal
|
|
500
|
|
(response-code
|
|
(http-get
|
|
uri
|
|
#:port (non-blocking-open-socket-for-uri uri)))))))
|
|
|
|
(run-fibers-for-tests
|
|
(lambda ()
|
|
(let* ((web-server
|
|
(run-knots-web-server
|
|
(lambda (request)
|
|
(values '((content-type . (text/plain))
|
|
(content-length . 3))
|
|
(lambda (port)
|
|
(display "foo" port))))
|
|
#:port 0)) ;; Bind to any port
|
|
(port
|
|
(web-server-port web-server))
|
|
(uri
|
|
(build-uri 'http #:host "127.0.0.1" #:port port)))
|
|
|
|
(let ((response
|
|
body
|
|
(http-get
|
|
uri
|
|
#:port (non-blocking-open-socket-for-uri uri))))
|
|
(assert-equal
|
|
"foo"
|
|
body)))))
|
|
|
|
(run-fibers-for-tests
|
|
(lambda ()
|
|
(let* ((web-server
|
|
(run-knots-web-server
|
|
(lambda (request)
|
|
(values '((content-type . (text/plain
|
|
(charset . "utf-8"))))
|
|
(lambda (port)
|
|
(display "☺" port))))
|
|
#:port 0)) ;; Bind to any port
|
|
(port
|
|
(web-server-port web-server))
|
|
(uri
|
|
(build-uri 'http #:host "127.0.0.1" #:port port)))
|
|
|
|
(let ((response
|
|
body
|
|
(http-get
|
|
uri
|
|
#:port (non-blocking-open-socket-for-uri uri))))
|
|
(assert-equal
|
|
"☺"
|
|
body)))))
|
|
|
|
(run-fibers-for-tests
|
|
(lambda ()
|
|
(let* ((web-server
|
|
(run-knots-web-server
|
|
(lambda (request)
|
|
(values '((content-type . (text/plain
|
|
(charset . "utf-8")))
|
|
(content-length . 3))
|
|
(lambda (port)
|
|
(display "☺" port))))
|
|
#:port 0)) ;; Bind to any port
|
|
(port
|
|
(web-server-port web-server))
|
|
(uri
|
|
(build-uri 'http #:host "127.0.0.1" #:port port)))
|
|
|
|
(let ((response
|
|
body
|
|
(http-get
|
|
uri
|
|
;; TODO Remove once using Guile 3.0.10
|
|
#:streaming? #t
|
|
#:port (non-blocking-open-socket-for-uri uri))))
|
|
(assert-equal
|
|
"☺"
|
|
(utf8->string
|
|
(get-bytevector-n body 3)))))))
|
|
|
|
(run-fibers-for-tests
|
|
(lambda ()
|
|
(let* ((web-server
|
|
(run-knots-web-server
|
|
(lambda (request)
|
|
(if (string=? (utf8->string
|
|
(read-request-body/knots request))
|
|
"☺")
|
|
(values (build-response #:code 200)
|
|
"")
|
|
(values (build-response #:code 500)
|
|
"")))
|
|
#:port 0)) ;; Bind to any port
|
|
(port
|
|
(web-server-port web-server))
|
|
(uri
|
|
(build-uri 'http #:host "127.0.0.1" #:port port)))
|
|
|
|
(let ((response
|
|
body
|
|
(http-post
|
|
uri
|
|
#:body "☺"
|
|
#:port (non-blocking-open-socket-for-uri uri))))
|
|
(assert-equal
|
|
200
|
|
(response-code response))))))
|
|
|
|
(run-fibers-for-tests
|
|
(lambda ()
|
|
(let* ((channel (make-channel))
|
|
(web-server
|
|
(run-knots-web-server
|
|
(lambda (request)
|
|
(with-exception-handler
|
|
(lambda (exn)
|
|
(put-message channel exn))
|
|
(lambda ()
|
|
(read-request-body/knots request))
|
|
#:unwind? #t))
|
|
#:port 0)) ;; Bind to any port
|
|
(port
|
|
(web-server-port web-server))
|
|
(uri
|
|
(build-uri 'http #:host "127.0.0.1" #:port port)))
|
|
|
|
(let* ((port (non-blocking-open-socket-for-uri uri))
|
|
(request
|
|
(build-request
|
|
uri
|
|
#:method 'POST
|
|
#:version '(1 . 1)
|
|
#:headers `((connection close)
|
|
(content-length . 20)
|
|
(Content-Type . "application/octet-stream"))
|
|
#:port port)))
|
|
|
|
(set-port-encoding! port "ISO-8859-1")
|
|
(let ((request (write-request request port)))
|
|
(display "12")
|
|
(force-output port)
|
|
|
|
(close-port port)))
|
|
|
|
(assert-true
|
|
(request-body-ended-prematurely-error?
|
|
(get-message channel))))))
|
|
|
|
;; Test handling of exceptions when writing the response to a client
|
|
(run-fibers-for-tests
|
|
(lambda ()
|
|
(let* ((exception-handled-sucecssfully-channel
|
|
(make-channel))
|
|
(port-closed-channel (make-channel))
|
|
(web-server
|
|
(run-knots-web-server
|
|
(lambda (request)
|
|
;; TODO Not sure why buffering makes a difference here
|
|
(setvbuf (request-port request) 'none)
|
|
(get-message port-closed-channel)
|
|
(values '((content-type . (text/plain)))
|
|
"Hello, World!"))
|
|
#:write-response-exception-handler
|
|
(lambda (exn request)
|
|
(spawn-fiber
|
|
(lambda ()
|
|
(put-message exception-handled-sucecssfully-channel
|
|
#t)))
|
|
#f)
|
|
#:port 0)) ;; Bind to any port
|
|
(port
|
|
(web-server-port web-server))
|
|
(uri
|
|
(build-uri 'http #:host "127.0.0.1" #:port port)))
|
|
|
|
(let ((request-port (non-blocking-open-socket-for-uri uri)))
|
|
(write-request
|
|
(build-request uri)
|
|
request-port)
|
|
(close-port request-port))
|
|
(put-message port-closed-channel #t)
|
|
|
|
(assert-equal (get-message exception-handled-sucecssfully-channel)
|
|
#t))))
|
|
|
|
(run-fibers-for-tests
|
|
(lambda ()
|
|
(let* ((web-server
|
|
(run-knots-web-server
|
|
(lambda (request)
|
|
(match (split-and-decode-uri-path
|
|
(uri-path (request-uri request)))
|
|
(("head-no-body")
|
|
(values '((content-type . (text/plain)))
|
|
#f))
|
|
(("head-empty-body")
|
|
(values '((content-type . (text/plain)))
|
|
""))
|
|
(("head-no-body-with-content-length")
|
|
(values '((content-type . (text/plain))
|
|
(content-length . 10))
|
|
#f))
|
|
(("head-with-body")
|
|
(values '((content-type . (text/plain)))
|
|
"foo"))
|
|
(("head-procedure-body")
|
|
(values '((content-type . (text/plain)))
|
|
(lambda _
|
|
(error "should not be run"))))
|
|
(("head-procedure-body-with-content-length")
|
|
(values '((content-type . (text/plain))
|
|
(content-length . 10))
|
|
(lambda _
|
|
(error "should not be run"))))))
|
|
#:port 0)) ;; Bind to any port
|
|
(port
|
|
(web-server-port web-server)))
|
|
|
|
(define* (head path)
|
|
(let ((uri
|
|
(build-uri 'http #:host "127.0.0.1" #:port port
|
|
#:path path)))
|
|
(http-head
|
|
uri
|
|
#:port (non-blocking-open-socket-for-uri uri))))
|
|
|
|
(let ((response
|
|
(head "/head-no-body")))
|
|
(assert-equal 200 (response-code response)))
|
|
(let ((response
|
|
(head "/head-empty-body")))
|
|
(assert-equal 200 (response-code response))
|
|
(assert-equal 0 (response-content-length response)))
|
|
(let ((response
|
|
(head "/head-no-body-with-content-length")))
|
|
(assert-equal 200 (response-code response))
|
|
(assert-equal 10 (response-content-length response)))
|
|
(let ((response
|
|
(head "/head-with-body")))
|
|
(assert-equal 200 (response-code response))
|
|
(assert-equal 3 (response-content-length response)))
|
|
(let ((response
|
|
(head "/head-procedure-body")))
|
|
(assert-equal 200 (response-code response)))
|
|
(let ((response
|
|
(head "/head-procedure-body-with-content-length")))
|
|
(assert-equal 200 (response-code response))
|
|
(assert-equal 10 (response-content-length response))))))
|
|
|
|
(display "web-server test finished successfully\n")
|