source: project/release/4/http-client/trunk/tests/testlib.scm @ 34001

Last change on this file since 34001 was 34001, checked in by sjamaan, 3 years ago

http-client: Increase timeouts so we (hopefully) don't get stupid timeout exceptions on slow Salmonella runs

File size: 3.0 KB
Line 
1;; http-client test library.  This adds some helpers for setting up
2;; fake connections and logging the requests and responses.
3
4;; TODO: Test HTTPS somehow?
5
6(use test uri-common intarweb srfi-1 srfi-18 tcp posix)
7
8;; From intarweb
9(define-syntax test-error*
10  (syntax-rules ()
11    ((_ ?msg (?error-type ...) ?expr)
12     (let-syntax ((expression:
13                   (syntax-rules ()
14                     ((_ ?expr)
15                      (condition-case (begin ?expr "<no error thrown>")
16                                      ((?error-type ...) '(?error-type ...))
17                                      (exn () (##sys#slot exn 1)))))))
18       (test ?msg '(?error-type ...) (expression: ?expr))))
19    ((_ ?msg ?error-type ?expr)
20     (test-error* ?msg (?error-type) ?expr))
21    ((_ ?error-type ?expr)
22     (test-error* (sprintf "~S" '?expr) ?error-type ?expr))))
23
24(define-record log request body)
25
26(define server-port #f)
27
28(server-connector (lambda (uri proxy)
29                    (tcp-connect "localhost" server-port)) )
30
31(tcp-read-timeout 100)
32(tcp-write-timeout 100)
33
34;; Set up a number of fake connections to a "server", with predefined
35;; responses for each (expected) request.
36(define (with-server-responses thunk . responses)
37  (let* ((response-count (length responses))
38         (logs '())
39         (listener (tcp-listen 0 0 "localhost"))
40         (server-thread
41          (thread-start!
42           (lambda ()
43             (let lp ()
44               (if (null? responses)
45                   (tcp-close listener)
46                   (receive (in out) (tcp-accept listener)
47                     (let* ((req (read-request in))
48                            (h (request-headers req))
49                            (log (make-log req #f))
50                            (response (car responses)))
51
52                       (when ((request-has-message-body?) req)
53                         (let* ((len (header-value 'content-length h))
54                                (body (read-string len (request-port req))))
55                           (log-body-set! log body)))
56                       (set! logs (cons log logs))
57                       (set! responses (cdr responses))
58                       (display response out)
59                       (close-output-port out)
60                       (lp)))))))))
61
62    (set! server-port (tcp-listener-port listener))
63
64    ;; TODO: Figure out how to ensure connections get closed correctly
65    (dynamic-wind
66        void
67        thunk
68        (lambda ()
69          (handle-exceptions exn (thread-terminate! server-thread)
70            ;; To close idle connections here to catch a regression
71            ;; where we would loop endlessly...
72            (close-idle-connections!)
73            (thread-join! server-thread 0)) ))
74   
75    ;; Return the accumulated logs if all went well
76    (if (not (= (length logs) response-count))
77        (error (sprintf "Not enough requests.  Expected ~A responses, but logged ~A requests!" response-count (length logs)))
78        (reverse logs)) ))
79
80(define (with-server-response thunk response)
81  (car (with-server-responses thunk response)))
Note: See TracBrowser for help on using the repository browser.