summaryrefslogtreecommitdiff
path: root/tests/testlib.scm
blob: 92e69daa6334246b807e7cc5c452b11da7c9b3d5 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
;; http-client test library.  This adds some helpers for setting up
;; fake connections and logging the requests and responses.

;; TODO: Test HTTPS somehow?

(import test uri-common intarweb srfi-1 srfi-18 (chicken tcp)
        (chicken string) (chicken io) (chicken file) (chicken format))

;; From intarweb
(define-syntax test-error*
  (syntax-rules ()
    ((_ ?msg (?error-type ...) ?expr)
     (let-syntax ((expression
                   (syntax-rules ()
                     ((_ ?expr)
                      (condition-case (begin ?expr "<no error thrown>")
                                      ((?error-type ...) '(?error-type ...))
                                      (exn () (##sys#slot exn 1)))))))
       (test ?msg '(?error-type ...) (expression ?expr))))
    ((_ ?msg ?error-type ?expr)
     (test-error* ?msg (?error-type) ?expr))
    ((_ ?error-type ?expr)
     (test-error* (sprintf "~S" '?expr) ?error-type ?expr))))

(define-record log request body)

(define server-port #f)

(server-connector (lambda (uri proxy)
                    (tcp-connect "localhost" server-port)) )

;; These need to be reasonably high to avoid lots of errors on slow
;; VMs and some OSes (FreeBSD in particular?), see also Salmonella.
;; At least 100 seems to be too low, so we aim high and set it to 500.
(tcp-read-timeout 500)
(tcp-write-timeout 500)

;; Set up a number of fake connections to a "server", with predefined
;; responses for each (expected) request.
(define (with-server-responses thunk . responses)
  (let* ((response-count (length responses))
         (logs '())
         (listener (tcp-listen 0 0 "localhost"))
         (server-thread
          (thread-start!
           (make-thread
            (lambda ()
              (let lp ()
                (if (null? responses)
                    (tcp-close listener)
                    (receive (in out) (tcp-accept listener)
                      (let* ((req (read-request in))
                             (h (request-headers req))
                             (log (make-log req #f))
                             (response (car responses)))

                        (when ((request-has-message-body?) req)
                          (let* ((len (header-value 'content-length h))
                                 (body (read-string len (request-port req))))
                            (log-body-set! log body)))
                        (set! logs (cons log logs))
                        (set! responses (cdr responses))
                        (display response out)
                        (close-output-port out)
                        (lp))))))
            'server-thread))))

    (set! server-port (tcp-listener-port listener))

    ;; TODO: Figure out how to ensure connections get closed correctly
    (dynamic-wind
        void
        thunk
        (lambda ()
          (handle-exceptions exn (thread-terminate! server-thread)
            ;; To close idle connections here to catch a regression
            ;; where we would loop endlessly...
            (close-idle-connections!)
            (thread-join! server-thread 0)) ))
    
    ;; Return the accumulated logs if all went well
    (if (not (= (length logs) response-count))
        (error (sprintf "Not enough requests.  Expected ~A responses, but logged ~A requests!" response-count (length logs)))
        (reverse logs)) ))

(define (with-server-response thunk response)
  (car (with-server-responses thunk response)))