diff options
Diffstat (limited to 'tests/server.lisp')
| -rw-r--r-- | tests/server.lisp | 156 |
1 files changed, 156 insertions, 0 deletions
diff --git a/tests/server.lisp b/tests/server.lisp new file mode 100644 index 0000000..7725485 --- /dev/null +++ b/tests/server.lisp @@ -0,0 +1,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)))) |