guile-knots/tests/web.scm

(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")