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
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
|
(in-package #:cepis/tests)
(defstruct (fake-server (:constructor %make-fake-server))
"A throwaway HTTP server on a random loopback port.
The suite points a client at it with :base-url, so the code path exercised is
the one that runs in production, request construction and error body reading
included. Nothing is stubbed and no test touches the network."
socket
thread
port
(routes (make-hash-table :test #'equal))
(calls '())
(handler nil)
(lock (bt:make-lock))
(running t))
(defun reason-phrase (status)
(case status
(200 "OK")
(400 "Bad Request")
(404 "Not Found")
(429 "Too Many Requests")
(500 "Internal Server Error")
(503 "Service Unavailable")
(t "Status")))
(defun reply (status body &optional headers)
"A response the fake server can send: status line, body, extra headers."
(list status body headers))
(defun respond (server path response)
"Register RESPONSE for PATH.
RESPONSE is one `reply', or a list of them headed by :sequence — in which case
each request consumes the next one, which is how retrying is tested. The last
entry repeats once the list runs out."
(setf (gethash path (fake-server-routes server)) response))
(defun next-response (server path)
"Record the call and return the response registered for PATH."
(bt:with-lock-held ((fake-server-lock server))
(push path (fake-server-calls server))
(let ((handler (fake-server-handler server)))
(if handler
(funcall handler path)
(let ((response (gethash path (fake-server-routes server))))
(cond ((null response)
(reply 404 "{\"erro\":\"cep_nao_encontrado\"}"))
((eq (first response) :sequence)
(let ((remaining (rest response)))
(when (rest remaining)
(setf (gethash path (fake-server-routes server))
(cons :sequence (rest remaining))))
(first remaining)))
(t response)))))))
(defun call-count (server prefix)
"How many requests so far began with PREFIX."
(bt:with-lock-held ((fake-server-lock server))
(count-if (lambda (path)
(and (>= (length path) (length prefix))
(string= prefix path :end2 (length prefix))))
(fake-server-calls server))))
(defun total-calls (server)
(bt:with-lock-held ((fake-server-lock server))
(length (fake-server-calls server))))
(defun read-http-line (stream)
"Read one CRLF-terminated line of a request, or NIL at end of input."
(let ((line (make-string-output-stream))
(any nil))
(loop for byte = (read-byte stream nil nil)
do (cond ((null byte) (return))
((= byte 10) (setf any t) (return))
((= byte 13))
(t (setf any t) (write-char (code-char byte) line))))
(when any
(get-output-stream-string line))))
(defun write-http-response (stream status body headers)
(let* ((data (babel:string-to-octets body :encoding :utf-8))
(head (with-output-to-string (out)
(format out "HTTP/1.1 ~d ~a~c~c" status (reason-phrase status)
#\Return #\Newline)
(loop for (name . value) in headers
do (format out "~a: ~a~c~c" name value #\Return #\Newline))
(format out "Content-Length: ~d~c~c" (length data) #\Return #\Newline)
(format out "Connection: close~c~c~c~c"
#\Return #\Newline #\Return #\Newline))))
(write-sequence (babel:string-to-octets head :encoding :latin-1) stream)
(write-sequence data stream)
(finish-output stream)))
(defun handle-connection (server connection)
(let ((stream (usocket:socket-stream connection)))
(let ((request-line (read-http-line stream)))
(when request-line
(loop for header = (read-http-line stream)
while (and header (plusp (length header))))
(let* ((parts (uiop:split-string request-line :separator " "))
(path (or (second parts) "/")))
(destructuring-bind (status body &optional headers)
(next-response server path)
(write-http-response stream status body headers)))))))
(defun serve-loop (server)
(loop while (fake-server-running server)
do (when (usocket:wait-for-input (fake-server-socket server)
:timeout 0.05 :ready-only t)
(let ((connection (ignore-errors
(usocket:socket-accept (fake-server-socket server)
:element-type '(unsigned-byte 8)))))
(when connection
(bt:make-thread
(lambda ()
(unwind-protect
(ignore-errors (handle-connection server connection))
(ignore-errors (usocket:socket-close connection))))
:name "cepis-test-connection"))))))
(defun start-fake-server ()
(let* ((socket (usocket:socket-listen "127.0.0.1" 0
:reuse-address t
:element-type '(unsigned-byte 8)))
(server (%make-fake-server :socket socket
:port (usocket:get-local-port socket))))
(setf (fake-server-thread server)
(bt:make-thread (lambda () (serve-loop server)) :name "cepis-test-server"))
server))
(defun stop-fake-server (server)
(setf (fake-server-running server) nil)
(ignore-errors (bt:join-thread (fake-server-thread server)))
(ignore-errors (usocket:socket-close (fake-server-socket server))))
(defun fake-server-url (server)
(format nil "http://127.0.0.1:~d" (fake-server-port server)))
(defmacro with-fake-server ((server client &rest client-args) &body body)
"Run BODY with SERVER listening and CLIENT pointed at it.
The backoff is near zero because what is under test is the retry logic, not
the ability of `sleep' to sleep."
`(let ((,server (start-fake-server)))
(unwind-protect
(let ((,client (apply #'make-client
:base-url (fake-server-url ,server)
(append (list ,@client-args)
(list :timeout 5.0
:backoff-base 0.001
:backoff-max 0.01)))))
(declare (ignorable ,client))
,@body)
(stop-fake-server ,server))))
|