223 lines
8 KiB
Scheme
223 lines
8 KiB
Scheme
(use-modules (tests)
|
|
(fibers)
|
|
(srfi srfi-71)
|
|
(ice-9 rdelim)
|
|
(ice-9 exceptions)
|
|
(unit-test)
|
|
(web uri)
|
|
(web client)
|
|
(web request)
|
|
(web response)
|
|
(knots resource-pool)
|
|
(knots web-server)
|
|
(knots web))
|
|
|
|
;; Test that call-with-cached-connection passes the port to proc and
|
|
;; returns its result.
|
|
(run-fibers-for-tests
|
|
(lambda ()
|
|
(let* ((port (open-input-string ""))
|
|
(cache (make-fixed-size-resource-pool (list port))))
|
|
(assert-equal
|
|
'ok
|
|
(call-with-cached-connection cache (lambda (p) 'ok)))
|
|
(destroy-resource-pool cache))))
|
|
|
|
;; Test that call-with-cached-connection retries when the checked-out
|
|
;; port is already closed, using a fresh connection from the pool.
|
|
(run-fibers-for-tests
|
|
(lambda ()
|
|
(let* ((n 0)
|
|
(cache (make-resource-pool
|
|
(lambda ()
|
|
(set! n (+ n 1))
|
|
(if (= n 1)
|
|
(let ((p (open-input-string "")))
|
|
(close-port p)
|
|
p)
|
|
(open-input-string "")))
|
|
1
|
|
;; Without a destructor, the resource pool calls (#f port)
|
|
;; when destroying the closed-port resource, looping forever.
|
|
#:destructor (const #t))))
|
|
(assert-equal
|
|
'ok
|
|
(call-with-cached-connection cache (lambda (p) 'ok)))
|
|
(destroy-resource-pool cache))))
|
|
|
|
;; Test that call-with-connection-cache provides a working cache and
|
|
;; destroys it after the body returns.
|
|
(run-fibers-for-tests
|
|
(lambda ()
|
|
(let* ((web-server
|
|
(run-knots-web-server
|
|
(lambda (request)
|
|
(values '((content-type . (text/plain))) "ok"))
|
|
#:port 0))
|
|
(server-port (web-server-port web-server))
|
|
(uri (build-uri 'http #:host "127.0.0.1" #:port server-port)))
|
|
(assert-equal
|
|
200
|
|
(call-with-connection-cache
|
|
uri 1
|
|
(lambda (cache)
|
|
(call-with-cached-connection cache
|
|
(lambda (p)
|
|
(let ((response body
|
|
(http-get uri #:port p #:keep-alive? #t)))
|
|
(response-code response))))))))))
|
|
|
|
;; Test that http-fold-requests sends requests and folds over responses.
|
|
;; The proc must drain the body port between responses so that HTTP
|
|
;; pipelining works correctly.
|
|
(run-fibers-for-tests
|
|
(lambda ()
|
|
(let* ((web-server
|
|
(run-knots-web-server
|
|
(lambda (request)
|
|
(values '((content-type . (text/plain))) "ok"))
|
|
#:port 0))
|
|
(server-port (web-server-port web-server))
|
|
(uri (build-uri 'http #:host "127.0.0.1" #:port server-port))
|
|
(cache (make-connection-cache uri 1))
|
|
(requests (list (build-request uri)
|
|
(build-request uri))))
|
|
(let ((codes
|
|
(http-fold-requests
|
|
cache
|
|
(lambda (req resp body result)
|
|
(read-string body) ; drain body before next pipelined response
|
|
(cons (response-code resp) result))
|
|
'()
|
|
requests)))
|
|
(assert-equal '(200 200) codes))
|
|
(destroy-resource-pool cache))))
|
|
|
|
;; Test that http-fold-requests reconnects and retries remaining requests when
|
|
;; the server closes the connection mid-batch via Connection: close. Three
|
|
;; requests are sent in one batch; the server closes after the first response,
|
|
;; so the remaining two must be retried on a fresh connection.
|
|
(run-fibers-for-tests
|
|
(lambda ()
|
|
(let* ((n 0)
|
|
(web-server
|
|
(run-knots-web-server
|
|
(lambda (request)
|
|
(set! n (1+ n))
|
|
(if (= n 1)
|
|
(values '((content-type . (text/plain))
|
|
(connection . (close)))
|
|
"ok")
|
|
(values '((content-type . (text/plain))) "ok")))
|
|
#:port 0))
|
|
(server-port (web-server-port web-server))
|
|
(uri (build-uri 'http #:host "127.0.0.1" #:port server-port))
|
|
(cache (make-connection-cache uri 1))
|
|
(requests (list (build-request uri)
|
|
(build-request uri)
|
|
(build-request uri))))
|
|
(let ((codes
|
|
(http-fold-requests
|
|
cache
|
|
(lambda (req resp body result)
|
|
(read-string body)
|
|
(cons (response-code resp) result))
|
|
'()
|
|
requests)))
|
|
(assert-equal '(200 200 200) codes))
|
|
(destroy-resource-pool cache))))
|
|
|
|
;; Test that write errors in send-batch are handled gracefully. Each request
|
|
;; carries a large header so that the batch data exceeds the TCP send buffer,
|
|
;; causing write-request to fail while the server has already closed the
|
|
;; connection after the first response.
|
|
(run-fibers-for-tests
|
|
(lambda ()
|
|
(let* ((n 0)
|
|
(web-server
|
|
(run-knots-web-server
|
|
(lambda (request)
|
|
(set! n (1+ n))
|
|
(if (= n 1)
|
|
(values '((content-type . (text/plain))
|
|
(connection . (close)))
|
|
"ok")
|
|
(values '((content-type . (text/plain))) "ok")))
|
|
#:port 0))
|
|
(server-port (web-server-port web-server))
|
|
(uri (build-uri 'http #:host "127.0.0.1" #:port server-port))
|
|
(cache (make-connection-cache uri 1))
|
|
(n-requests 100)
|
|
;; 100 requests x ~100 KB of headers each = ~10 MB, well above
|
|
;; the typical TCP send buffer, so writes fail mid-batch.
|
|
(large-request
|
|
(build-request uri
|
|
#:headers
|
|
`((x-padding . ,(make-string 100000 #\a)))))
|
|
(requests (make-list n-requests large-request)))
|
|
(let ((codes
|
|
(http-fold-requests
|
|
cache
|
|
(lambda (req resp body result)
|
|
(read-string body)
|
|
(cons (response-code resp) result))
|
|
'()
|
|
requests)))
|
|
(assert-equal (make-list n-requests 200) codes))
|
|
(destroy-resource-pool cache))))
|
|
|
|
;; Test that http-fold-requests processes multiple batches. With batch-size 2
|
|
;; and 5 requests, three batches are needed; without the pending fix only the
|
|
;; first batch would be processed.
|
|
(run-fibers-for-tests
|
|
(lambda ()
|
|
(let* ((web-server
|
|
(run-knots-web-server
|
|
(lambda (request)
|
|
(values '((content-type . (text/plain))) "ok"))
|
|
#:port 0))
|
|
(server-port (web-server-port web-server))
|
|
(uri (build-uri 'http #:host "127.0.0.1" #:port server-port))
|
|
(cache (make-connection-cache uri 1))
|
|
(requests (make-list 5 (build-request uri))))
|
|
(let ((codes
|
|
(http-fold-requests
|
|
cache
|
|
(lambda (req resp body result)
|
|
(read-string body)
|
|
(cons (response-code resp) result))
|
|
'()
|
|
requests
|
|
#:batch-size 2)))
|
|
(assert-equal (make-list 5 200) codes))
|
|
(destroy-resource-pool cache))))
|
|
|
|
;; Test that an exception raised by proc propagates out of http-fold-requests.
|
|
(run-fibers-for-tests
|
|
(lambda ()
|
|
(let* ((web-server
|
|
(run-knots-web-server
|
|
(lambda (request)
|
|
(values '((content-type . (text/plain))) "ok"))
|
|
#:port 0))
|
|
(server-port (web-server-port web-server))
|
|
(uri (build-uri 'http #:host "127.0.0.1" #:port server-port))
|
|
(cache (make-connection-cache uri 1))
|
|
(requests (list (build-request uri))))
|
|
(assert-equal
|
|
'proc-exception
|
|
(exception-message
|
|
(with-exception-handler
|
|
(lambda (exn) exn)
|
|
(lambda ()
|
|
(http-fold-requests
|
|
cache
|
|
(lambda (req resp body result)
|
|
(raise-exception
|
|
(make-exception-with-message 'proc-exception)))
|
|
'()
|
|
requests))
|
|
#:unwind? #t)))
|
|
(destroy-resource-pool cache))))
|
|
|
|
(display "web test finished successfully\n")
|