Add (knots web)

tests/web.scm

@@ -0,0 +1,223 @@
+(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")