diff options
Diffstat (limited to 'test')
| -rw-r--r-- | test/http_server.c | 461 | ||||
| -rw-r--r-- | test/test_cepis.f90 | 886 | ||||
| -rw-r--r-- | test/test_server.f90 | 214 |
3 files changed, 1561 insertions, 0 deletions
diff --git a/test/http_server.c b/test/http_server.c new file mode 100644 index 0000000..623f958 --- /dev/null +++ b/test/http_server.c @@ -0,0 +1,461 @@ +/* + * A throwaway HTTP/1.1 server on a random loopback port. + * + * Fortran has no sockets, so the suite's server is C and is compiled and + * linked alongside the tests. Nothing is mocked: the client under test takes + * the same path it takes in production, libcurl included. It doubles as the + * test that base_url works, since without it none of the suite would run. + */ +#include <arpa/inet.h> +#include <errno.h> +#include <netinet/in.h> +#include <poll.h> +#include <pthread.h> +#include <stdlib.h> +#include <stdio.h> +#include <string.h> +#include <sys/socket.h> +#include <unistd.h> + +#define TS_MAX_ROUTES 32 +#define TS_MAX_REPLIES 8 +#define TS_MAX_CALLS 4096 +#define TS_REQUEST_MAX 262144 + +typedef struct { + long status; + char *body; + char *headers; +} ts_reply; + +typedef struct { + char *path; + ts_reply replies[TS_MAX_REPLIES]; + size_t count; + size_t served; +} ts_route; + +typedef struct { + int listen_fd; + int port; + pthread_t thread; + pthread_mutex_t lock; + int stopping; + ts_route routes[TS_MAX_ROUTES]; + size_t route_count; + ts_route fallback; + char *calls[TS_MAX_CALLS]; + size_t call_count; +} ts_server; + +static char *ts_dup(const char *text) +{ + size_t len = (text != NULL) ? strlen(text) : 0; + char *copy = malloc(len + 1); + + if (copy == NULL) + return NULL; + if (len > 0) + memcpy(copy, text, len); + copy[len] = '\0'; + return copy; +} + +static void route_clear(ts_route *route) +{ + size_t i; + + for (i = 0; i < route->count; i++) { + free(route->replies[i].body); + free(route->replies[i].headers); + } + route->count = 0; + route->served = 0; +} + +static ts_route *route_for(ts_server *server, const char *path, int create) +{ + size_t i; + + for (i = 0; i < server->route_count; i++) + if (strcmp(server->routes[i].path, path) == 0) + return &server->routes[i]; + if (!create || server->route_count >= TS_MAX_ROUTES) + return NULL; + server->routes[server->route_count].path = ts_dup(path); + return &server->routes[server->route_count++]; +} + +static void route_push(ts_route *route, long status, const char *body, + const char *headers) +{ + if (route == NULL || route->count >= TS_MAX_REPLIES) + return; + route->replies[route->count].status = status; + route->replies[route->count].body = ts_dup(body); + route->replies[route->count].headers = ts_dup(headers); + route->count++; +} + +static const char *reason_phrase(long status) +{ + switch (status) { + case 200: + return "OK"; + case 400: + return "Bad Request"; + case 404: + return "Not Found"; + case 429: + return "Too Many Requests"; + case 500: + return "Internal Server Error"; + case 502: + return "Bad Gateway"; + case 503: + return "Service Unavailable"; + case 504: + return "Gateway Timeout"; + default: + return "Status"; + } +} + +static int read_request_path(int fd, char *out, size_t out_size) +{ + static char buffer[TS_REQUEST_MAX]; + size_t used = 0; + const char *start; + const char *space; + size_t len; + + for (;;) { + ssize_t got; + struct pollfd pfd; + + pfd.fd = fd; + pfd.events = POLLIN; + pfd.revents = 0; + if (poll(&pfd, 1, 5000) <= 0) + return 0; + got = read(fd, buffer + used, sizeof(buffer) - used - 1); + if (got <= 0) + return 0; + used += (size_t)got; + buffer[used] = '\0'; + if (strstr(buffer, "\r\n\r\n") != NULL) + break; + if (used + 1 >= sizeof(buffer)) + return 0; + } + + start = strchr(buffer, ' '); + if (start == NULL) + return 0; + start++; + space = strchr(start, ' '); + if (space == NULL) + return 0; + len = (size_t)(space - start); + if (len + 1 > out_size) + return 0; + memcpy(out, start, len); + out[len] = '\0'; + return 1; +} + +static void write_all(int fd, const char *data, size_t len) +{ + size_t sent = 0; + + while (sent < len) { + ssize_t wrote = write(fd, data + sent, len - sent); + if (wrote <= 0) { + if (wrote < 0 && errno == EINTR) + continue; + return; + } + sent += (size_t)wrote; + } +} + +static void serve(ts_server *server, int fd) +{ + static char path[TS_REQUEST_MAX]; + char head[1024]; + ts_route *route; + long status; + char *body; + char *headers; + size_t index; + int head_len; + + if (!read_request_path(fd, path, sizeof(path))) + return; + + pthread_mutex_lock(&server->lock); + if (server->call_count < TS_MAX_CALLS) + server->calls[server->call_count++] = ts_dup(path); + + route = route_for(server, path, 0); + if (route == NULL || route->count == 0) + route = &server->fallback; + + if (route->count == 0) { + pthread_mutex_unlock(&server->lock); + head_len = snprintf(head, sizeof(head), + "HTTP/1.1 404 Not Found\r\n" + "Content-Length: 0\r\n" + "Connection: close\r\n\r\n"); + if (head_len > 0) + write_all(fd, head, (size_t)head_len); + return; + } + + index = route->served; + if (index >= route->count) + index = route->count - 1; + route->served++; + + status = route->replies[index].status; + body = ts_dup(route->replies[index].body); + headers = ts_dup(route->replies[index].headers); + pthread_mutex_unlock(&server->lock); + + head_len = snprintf(head, sizeof(head), + "HTTP/1.1 %ld %s\r\n" + "Content-Type: application/octet-stream\r\n" + "Content-Length: %zu\r\n" + "Connection: close\r\n" + "%s%s" + "\r\n", + status, reason_phrase(status), + body != NULL ? strlen(body) : 0, + (headers != NULL && headers[0] != '\0') ? headers : "", + (headers != NULL && headers[0] != '\0') ? "\r\n" : ""); + if (head_len > 0) + write_all(fd, head, (size_t)head_len); + if (body != NULL) + write_all(fd, body, strlen(body)); + free(body); + free(headers); +} + +static void *accept_loop(void *argument) +{ + ts_server *server = argument; + + for (;;) { + struct pollfd pfd; + int fd; + + pthread_mutex_lock(&server->lock); + if (server->stopping) { + pthread_mutex_unlock(&server->lock); + return NULL; + } + pthread_mutex_unlock(&server->lock); + + pfd.fd = server->listen_fd; + pfd.events = POLLIN; + pfd.revents = 0; + if (poll(&pfd, 1, 20) <= 0) + continue; + + fd = accept(server->listen_fd, NULL, NULL); + if (fd < 0) + continue; + serve(server, fd); + shutdown(fd, SHUT_WR); + close(fd); + } +} + +void *ts_start(void) +{ + struct sockaddr_in address; + socklen_t length = sizeof(address); + ts_server *server = calloc(1, sizeof(*server)); + int reuse = 1; + + if (server == NULL) + return NULL; + pthread_mutex_init(&server->lock, NULL); + + server->listen_fd = socket(AF_INET, SOCK_STREAM, 0); + if (server->listen_fd < 0) { + free(server); + return NULL; + } + setsockopt(server->listen_fd, SOL_SOCKET, SO_REUSEADDR, &reuse, + sizeof(reuse)); + + memset(&address, 0, sizeof(address)); + address.sin_family = AF_INET; + address.sin_addr.s_addr = htonl(INADDR_LOOPBACK); + address.sin_port = 0; + + if (bind(server->listen_fd, (struct sockaddr *)&address, + sizeof(address)) != 0 || + listen(server->listen_fd, 64) != 0 || + getsockname(server->listen_fd, (struct sockaddr *)&address, + &length) != 0) { + close(server->listen_fd); + free(server); + return NULL; + } + + server->port = ntohs(address.sin_port); + + if (pthread_create(&server->thread, NULL, accept_loop, server) != 0) { + close(server->listen_fd); + free(server); + return NULL; + } + return server; +} + +void ts_stop(void *handle) +{ + ts_server *server = handle; + size_t i; + + if (server == NULL) + return; + pthread_mutex_lock(&server->lock); + server->stopping = 1; + pthread_mutex_unlock(&server->lock); + pthread_join(server->thread, NULL); + close(server->listen_fd); + + for (i = 0; i < server->route_count; i++) { + route_clear(&server->routes[i]); + free(server->routes[i].path); + } + route_clear(&server->fallback); + for (i = 0; i < server->call_count; i++) + free(server->calls[i]); + pthread_mutex_destroy(&server->lock); + free(server); +} + +int ts_port(void *handle) +{ + ts_server *server = handle; + + return (server != NULL) ? server->port : 0; +} + +void ts_reset(void *handle) +{ + ts_server *server = handle; + size_t i; + + if (server == NULL) + return; + pthread_mutex_lock(&server->lock); + for (i = 0; i < server->route_count; i++) { + route_clear(&server->routes[i]); + free(server->routes[i].path); + server->routes[i].path = NULL; + } + server->route_count = 0; + route_clear(&server->fallback); + for (i = 0; i < server->call_count; i++) + free(server->calls[i]); + server->call_count = 0; + pthread_mutex_unlock(&server->lock); +} + +void ts_respond(void *handle, const char *path, long status, const char *body, + const char *headers) +{ + ts_server *server = handle; + ts_route *route; + + pthread_mutex_lock(&server->lock); + route = route_for(server, path, 1); + if (route != NULL) { + route_clear(route); + route_push(route, status, body, headers); + } + pthread_mutex_unlock(&server->lock); +} + +void ts_respond_more(void *handle, const char *path, long status, + const char *body, const char *headers) +{ + ts_server *server = handle; + + pthread_mutex_lock(&server->lock); + route_push(route_for(server, path, 1), status, body, headers); + pthread_mutex_unlock(&server->lock); +} + +void ts_respond_default(void *handle, long status, const char *body, + const char *headers) +{ + ts_server *server = handle; + + pthread_mutex_lock(&server->lock); + route_clear(&server->fallback); + route_push(&server->fallback, status, body, headers); + pthread_mutex_unlock(&server->lock); +} + +size_t ts_count(void *handle, const char *prefix) +{ + ts_server *server = handle; + size_t total = 0; + size_t len = strlen(prefix); + size_t i; + + pthread_mutex_lock(&server->lock); + for (i = 0; i < server->call_count; i++) + if (server->calls[i] != NULL && + strncmp(server->calls[i], prefix, len) == 0) + total++; + pthread_mutex_unlock(&server->lock); + return total; +} + +size_t ts_total(void *handle) +{ + ts_server *server = handle; + size_t total; + + pthread_mutex_lock(&server->lock); + total = server->call_count; + pthread_mutex_unlock(&server->lock); + return total; +} + +size_t ts_path_length(void *handle, size_t index) +{ + ts_server *server = handle; + size_t len = 0; + + pthread_mutex_lock(&server->lock); + if (index < server->call_count && server->calls[index] != NULL) + len = strlen(server->calls[index]); + pthread_mutex_unlock(&server->lock); + return len; +} + +void ts_path_copy(void *handle, size_t index, char *out, size_t out_size) +{ + ts_server *server = handle; + + if (out_size == 0) + return; + out[0] = '\0'; + pthread_mutex_lock(&server->lock); + if (index < server->call_count && server->calls[index] != NULL) { + size_t len = strlen(server->calls[index]); + if (len >= out_size) + len = out_size - 1; + memcpy(out, server->calls[index], len); + out[len] = '\0'; + } + pthread_mutex_unlock(&server->lock); +} diff --git a/test/test_cepis.f90 b/test/test_cepis.f90 new file mode 100644 index 0000000..348e9df --- /dev/null +++ b/test/test_cepis.f90 @@ -0,0 +1,886 @@ +!> The suite. +!> +!> Every client test points `base_url` at a real HTTP server on loopback, so +!> the code path exercised is the one that runs in production, libcurl and all. +!> The parsers are also driven directly, with long and quoted values, because +!> silent truncation is the failure mode a hand-written Fortran parser is most +!> likely to have. +program test_cepis + use, intrinsic :: iso_c_binding, only: c_ptr, c_associated + use, intrinsic :: iso_fortran_env, only: real64, int64, output_unit + use cepis + use cepis_strings + use cepis_json + use cepis_csv + use cepis_http, only: http_parse_retry_after + use test_server + implicit none + + character(len=:), allocatable :: SE, PAULISTA, CITYWIDE, CSV_HEADER, HEALTH_BODY + integer :: passed, failed + type(c_ptr) :: server + character(len=:), allocatable :: base + + passed = 0 + failed = 0 + call build_fixtures() + + server = server_start() + if (.not. c_associated(server)) then + write (output_unit, '(A)') 'could not start the test server' + stop 1 + end if + base = server_base_url(server) + + call test_normalize_accepts_masked_and_unmasked() + call test_normalize_rejects_bad_format() + call test_format_cep() + call test_json_reads_long_values_without_truncation() + call test_json_decodes_escapes_and_surrogates() + call test_json_rejects_garbage() + call test_csv_reads_quoted_and_long_values() + call test_csv_reads_crlf_and_bom() + call test_retry_after_parses_both_forms() + + call test_successful_lookup() + call test_reads_the_coordinate_when_present() + call test_municipality_coordinate_is_not_precise() + call test_malformed_geo_does_not_lose_the_address() + call test_new_api_field_does_not_break() + call test_not_found_is_not_retried() + call test_invalid_cep_never_leaves_the_machine() + call test_api_400_becomes_invalid_cep() + call test_response_that_is_not_json() + call test_retries_on_500_then_succeeds() + call test_exhausts_attempts_then_fails() + call test_max_attempts_one_disables_retry() + call test_429_becomes_rate_limited_with_retry_after() + call test_retry_after_http_date_is_understood() + call test_retry_after_honours_the_cap() + call test_network_error_when_nothing_listens() + call test_total_timeout_bounds_the_whole_call() + call test_batch_preserves_order_and_marks_missing() + call test_batch_field_with_comma_is_parsed() + call test_batch_empty_list_makes_no_request() + call test_batch_chunks_above_the_api_limit() + call test_batch_truncated_response_does_not_shift() + call test_batch_malformed_cep_is_not_found() + call test_batch_retries_on_503() + call test_health() + call test_health_degraded_does_not_fail() + call test_trailing_slash_is_not_duplicated() + call test_invalid_configuration_is_rejected() + call test_user_agent_identifies_the_library() + call test_status_names_exist() + + call server_stop(server) + deallocate (SE, PAULISTA, CITYWIDE, CSV_HEADER, HEALTH_BODY, base) + + write (output_unit, '(A)') '' + write (output_unit, '(A,I0,A,I0,A)') 'passed ', passed, ', failed ', failed, '' + if (failed > 0) stop 1 + +contains + + subroutine build_fixtures() + SE = '{"cep":"01001000","logradouro":"Pra\u00e7a da S\u00e9",' + SE = SE//'"complemento":"lado \u00edmpar","unidade":"","bairro":"S\u00e9",' + SE = SE//'"localidade":"S\u00e3o Paulo","uf":"SP","estado":"S\u00e3o Paulo",' + SE = SE//'"regiao":"Sudeste","ibge":"3550308","gia":"1004","ddd":"11",' + SE = SE//'"siafi":"7107"}' + + PAULISTA = '{"cep":"01310100","logradouro":"Avenida Paulista",' + PAULISTA = PAULISTA//'"complemento":"","unidade":"","bairro":"Bela Vista",' + PAULISTA = PAULISTA//'"localidade":"Sao Paulo","uf":"SP","estado":"Sao Paulo",' + PAULISTA = PAULISTA//'"regiao":"Sudeste","ibge":"3550308","gia":"1004",' + PAULISTA = PAULISTA//'"ddd":"11","siafi":"7107","geo":{"lat":-23.567202,' + PAULISTA = PAULISTA//'"lon":-46.649659,"raio_m":1084,"precisao":"logradouro"}}' + + CITYWIDE = '{"cep":"69900000","logradouro":"","complemento":"","unidade":"",' + CITYWIDE = CITYWIDE//'"bairro":"","localidade":"Rio Branco","uf":"AC",' + CITYWIDE = CITYWIDE//'"estado":"Acre","regiao":"Norte","ibge":"1200401",' + CITYWIDE = CITYWIDE//'"gia":"","ddd":"68","siafi":"0003","geo":{"lat":-9.9754,' + CITYWIDE = CITYWIDE//'"lon":-67.8249,"raio_m":21400,"precisao":"localidade"}}' + + CSV_HEADER = 'cep,logradouro,complemento,unidade,bairro,localidade,uf,' + CSV_HEADER = CSV_HEADER//'estado,regiao,ibge,gia,ddd,siafi' + + HEALTH_BODY = '{"status":"ok","dne":"26071","ceps":1596168,"geo":894489,' + HEALTH_BODY = HEALTH_BODY//'"base_gerada_em":"2026-07-24T03:48:28Z"}' + end subroutine build_fixtures + + subroutine check(condition, name) + logical, intent(in) :: condition + character(len=*), intent(in) :: name + + if (condition) then + passed = passed + 1 + else + failed = failed + 1 + write (output_unit, '(A)') 'FAIL '//name + end if + end subroutine check + + subroutine local_client(client, max_attempts, backoff_max, total_timeout, url) + type(cepis_client), intent(out) :: client + integer, intent(in), optional :: max_attempts + real(real64), intent(in), optional :: backoff_max + real(real64), intent(in), optional :: total_timeout + character(len=*), intent(in), optional :: url + integer :: status + character(len=:), allocatable :: message + + if (present(url)) then + call cepis_client_init(client, status, message, base_url=url, & + timeout=5.0_real64, backoff_base=0.001_real64, & + backoff_max=0.05_real64) + else + call cepis_client_init(client, status, message, base_url=base, & + timeout=5.0_real64, backoff_base=0.001_real64, & + backoff_max=0.05_real64) + end if + if (present(max_attempts)) client%max_attempts = max_attempts + if (present(backoff_max)) client%backoff_max = backoff_max + if (present(total_timeout)) client%total_timeout = total_timeout + end subroutine local_client + + function elapsed_since(start) result(seconds) + integer(int64), intent(in) :: start + real(real64) :: seconds + integer(int64) :: now, rate + + call system_clock(now, rate) + seconds = real(now - start, real64)/real(max(rate, 1_int64), real64) + end function elapsed_since + + function now_ticks() result(ticks) + integer(int64) :: ticks, rate + + call system_clock(ticks, rate) + end function now_ticks + + function occurrences(text, needle) result(total) + character(len=*), intent(in) :: text + character(len=*), intent(in) :: needle + integer :: total, at, from + + total = 0 + from = 1 + do + at = index(text(from:), needle) + if (at == 0) exit + total = total + 1 + from = from + at + len(needle) - 1 + if (from > len(text)) exit + end do + end function occurrences + + subroutine test_normalize_accepts_masked_and_unmasked() + character(len=:), allocatable :: digits, message + integer :: status + + call cepis_normalize_cep('01001-000', digits, status, message) + call check(status == CEPIS_OK .and. digits == '01001000', 'normalize masked') + + call cepis_normalize_cep('01001000', digits, status, message) + call check(status == CEPIS_OK .and. digits == '01001000', 'normalize unmasked') + + call cepis_normalize_cep(' 01001-000 ', digits, status, message) + call check(status == CEPIS_OK .and. digits == '01001000', 'normalize padded') + + call cepis_normalize_cep('01.001-000', digits, status, message) + call check(status == CEPIS_OK .and. digits == '01001000', 'normalize dotted') + end subroutine test_normalize_accepts_masked_and_unmasked + + subroutine test_normalize_rejects_bad_format() + character(len=:), allocatable :: digits, message + integer :: status + + call cepis_normalize_cep('1234567', digits, status, message) + call check(status == CEPIS_ERR_INVALID_CEP, 'normalize rejects 7 digits') + + call cepis_normalize_cep('123456789', digits, status, message) + call check(status == CEPIS_ERR_INVALID_CEP, 'normalize rejects 9 digits') + + call cepis_normalize_cep('0100100a', digits, status, message) + call check(status == CEPIS_ERR_INVALID_CEP, 'normalize rejects letters') + + call cepis_normalize_cep('', digits, status, message) + call check(status == CEPIS_ERR_INVALID_CEP, 'normalize rejects empty') + + call check(len(message) > 0, 'normalize explains the failure') + end subroutine test_normalize_rejects_bad_format + + subroutine test_format_cep() + call check(cepis_format_cep('01001000') == '01001-000', 'format_cep masks') + call check(cepis_format_cep('123') == '', 'format_cep rejects short input') + end subroutine test_format_cep + + subroutine test_json_reads_long_values_without_truncation() + type(json_document) :: doc + character(len=:), allocatable :: message, long, body + logical :: ok + integer :: i + + long = '' + do i = 1, 400 + long = long//'Rua Muito Comprida ' + end do + + body = '{"logradouro":"'//long//'","uf":"SP"}' + call json_parse(body, doc, ok, message) + call check(ok, 'json parses a long document') + call check(doc%field_text(doc%root, 'logradouro') == long, & + 'json keeps a 7600-character value intact') + call check(len(doc%field_text(doc%root, 'logradouro')) == len(long), & + 'json does not truncate a long value') + call check(doc%field_text(doc%root, 'uf') == 'SP', & + 'json reads the field after a long one') + end subroutine test_json_reads_long_values_without_truncation + + subroutine test_json_decodes_escapes_and_surrogates() + type(json_document) :: doc + character(len=:), allocatable :: message + character(len=:), allocatable :: expected + logical :: ok + + call json_parse(SE, doc, ok, message) + call check(ok, 'json parses the native contract') + + expected = 'Pra'//char(195)//char(167)//'a da S'//char(195)//char(169) + call check(doc%field_text(doc%root, 'logradouro') == expected, & + 'json decodes \u escapes to UTF-8') + + call json_parse('{"a":"x\ty\ny","b":"\ud83d\ude00","c":"\\","d":"\""}', & + doc, ok, message) + call check(ok, 'json parses every escape form') + call check(doc%field_text(doc%root, 'a') == 'x'//char(9)//'y'//char(10)//'y', & + 'json decodes control escapes') + call check(doc%field_text(doc%root, 'b') == & + char(240)//char(159)//char(152)//char(128), & + 'json decodes a surrogate pair') + call check(doc%field_text(doc%root, 'c') == char(92), 'json decodes a backslash') + call check(doc%field_text(doc%root, 'd') == '"', 'json decodes a quote') + end subroutine test_json_decodes_escapes_and_surrogates + + subroutine test_json_rejects_garbage() + type(json_document) :: doc + character(len=:), allocatable :: message + logical :: ok + + call json_parse('<html>nope</html>', doc, ok, message) + call check(.not. ok, 'json rejects HTML') + call check(len(message) > 0, 'json says why it rejected the body') + + call json_parse('{"a":1', doc, ok, message) + call check(.not. ok, 'json rejects a truncated object') + + call json_parse('{"a":1} trailing', doc, ok, message) + call check(.not. ok, 'json rejects trailing characters') + end subroutine test_json_rejects_garbage + + subroutine test_csv_reads_quoted_and_long_values() + type(csv_table) :: table + character(len=:), allocatable :: message, long, body + logical :: ok + integer :: i + + long = '' + do i = 1, 500 + long = long//'ABCDEFGHIJ' + end do + + body = 'cep,logradouro,uf'//char(10)// & + '01001000,"Rua Um, Dois",SP'//char(10)// & + '01001001,"He said ""hi""",RJ'//char(10)// & + '01001002,'//long//',MG'//char(10) + + call csv_parse(body, table, ok, message) + call check(ok, 'csv parses the document') + call check(table%height() == 4, 'csv finds every row') + call check(table%cell(2, 'logradouro') == 'Rua Um, Dois', & + 'csv keeps a comma inside a quoted field') + call check(table%cell(2, 'uf') == 'SP', 'csv does not shift after a quoted field') + call check(table%cell(3, 'logradouro') == 'He said "hi"', & + 'csv unescapes a doubled quote') + call check(table%cell(4, 'logradouro') == long, & + 'csv keeps a 5000-character value intact') + call check(table%cell(4, 'uf') == 'MG', 'csv reads the column after a long one') + call check(table%cell(2, 'missing') == '', 'csv returns empty for an absent column') + end subroutine test_csv_reads_quoted_and_long_values + + subroutine test_csv_reads_crlf_and_bom() + type(csv_table) :: table + character(len=:), allocatable :: message, body + logical :: ok + + body = char(239)//char(187)//char(191)//'cep,uf'//char(13)//char(10)// & + '01001000,SP'//char(13)//char(10) + call csv_parse(body, table, ok, message) + call check(ok, 'csv parses CRLF with a byte-order mark') + call check(table%column('cep') == 1, 'csv strips the byte-order mark') + call check(table%cell(2, 'uf') == 'SP', 'csv strips the carriage return') + + call csv_parse('cep,uf'//char(10)//'01001000,"unterminated', table, ok, message) + call check(.not. ok, 'csv rejects an unterminated quoted field') + end subroutine test_csv_reads_crlf_and_bom + + subroutine test_retry_after_parses_both_forms() + real(real64) :: seconds + logical :: ok + + call http_parse_retry_after(' 120 ', seconds, ok) + call check(ok .and. abs(seconds - 120.0_real64) < 1.0e-9_real64, & + 'Retry-After reads a number of seconds') + + call http_parse_retry_after('Wed, 21 Oct 2099 07:28:00 GMT', seconds, ok) + call check(ok .and. seconds > 1.0e9_real64, 'Retry-After reads an HTTP date') + + call http_parse_retry_after('Thu, 01 Jan 1970 00:00:00 GMT', seconds, ok) + call check(ok .and. seconds < 1.0e-9_real64, & + 'Retry-After in the past is not a negative wait') + + call http_parse_retry_after('not a date', seconds, ok) + call check(.not. ok, 'Retry-After ignores nonsense') + end subroutine test_retry_after_parses_both_forms + + subroutine test_successful_lookup() + type(cepis_client) :: client + type(cepis_address) :: address + character(len=:), allocatable :: message + integer :: status + + call server_reset(server) + call server_respond(server, '/01001000', 200, SE, '') + call local_client(client) + + call client%lookup('01001-000', address, status, message) + call check(status == CEPIS_OK, 'lookup succeeds') + call check(address%found, 'lookup marks the address found') + call check(address%cep == '01001000', 'lookup reads cep') + call check(address%uf == 'SP', 'lookup reads uf') + call check(address%ibge == '3550308', 'lookup reads ibge') + call check(address%unidade == '', 'an absent field is the empty string') + call check(address%formatted_cep() == '01001-000', 'formatted_cep masks') + call check(.not. address%has_geo, 'no geo block means has_geo is false') + call check(len(address%raw) > 0, 'lookup keeps the raw body') + call check(server_path(server, 1) == '/01001000', 'lookup asks for the right path') + end subroutine test_successful_lookup + + subroutine test_reads_the_coordinate_when_present() + type(cepis_client) :: client + type(cepis_address) :: address + character(len=:), allocatable :: message + integer :: status + + call server_reset(server) + call server_respond(server, '/01310100', 200, PAULISTA, '') + call local_client(client) + + call client%lookup('01310100', address, status, message) + call check(status == CEPIS_OK, 'lookup with geo succeeds') + call check(address%has_geo, 'has_geo is true when the block is present') + call check(abs(address%geo%lat + 23.567202_real64) < 1.0e-6_real64, 'geo lat') + call check(abs(address%geo%lon + 46.649659_real64) < 1.0e-6_real64, 'geo lon') + call check(address%geo%raio_m == 1084, 'geo raio_m') + call check(address%geo%precisao == 'logradouro', 'geo precisao') + call check(address%geo%is_precise(), 'a street coordinate is precise') + end subroutine test_reads_the_coordinate_when_present + + subroutine test_municipality_coordinate_is_not_precise() + type(cepis_client) :: client + type(cepis_address) :: address + character(len=:), allocatable :: message + integer :: status + + call server_reset(server) + call server_respond(server, '/69900000', 200, CITYWIDE, '') + call local_client(client) + + call client%lookup('69900000', address, status, message) + call check(status == CEPIS_OK, 'city-wide lookup succeeds') + call check(address%has_geo, 'city-wide CEP carries a coordinate') + call check(.not. address%geo%is_precise(), & + 'a municipality centroid is not precise') + call check(address%geo%raio_m == 21400, 'city-wide raio_m is kilometres wide') + end subroutine test_municipality_coordinate_is_not_precise + + subroutine test_malformed_geo_does_not_lose_the_address() + type(cepis_client) :: client + type(cepis_address) :: address + character(len=:), allocatable :: message + integer :: status + + call server_reset(server) + call server_respond(server, '/01001000', 200, & + '{"cep":"01001000","localidade":"Sao Paulo","uf":"SP",'// & + '"geo":{"lat":"nope","lon":null}}', '') + call local_client(client) + + call client%lookup('01001000', address, status, message) + call check(status == CEPIS_OK, 'a malformed geo is not a failure') + call check(.not. address%has_geo, 'a malformed geo is dropped') + call check(address%localidade == 'Sao Paulo', 'the address survives') + end subroutine test_malformed_geo_does_not_lose_the_address + + subroutine test_new_api_field_does_not_break() + type(cepis_client) :: client + type(cepis_address) :: address + character(len=:), allocatable :: message + integer :: status + + call server_reset(server) + call server_respond(server, '/01001000', 200, & + '{"cep":"01001000","uf":"SP","novidade":{"a":[1,2,3]},'// & + '"outra":true}', '') + call local_client(client) + + call client%lookup('01001000', address, status, message) + call check(status == CEPIS_OK, 'an unknown field does not break the client') + call check(address%uf == 'SP', 'the known fields still arrive') + call check(index(address%raw, 'novidade') > 0, 'the unknown field survives in raw') + end subroutine test_new_api_field_does_not_break + + subroutine test_not_found_is_not_retried() + type(cepis_client) :: client + type(cepis_address) :: address + character(len=:), allocatable :: message + integer :: status + + call server_reset(server) + call server_respond(server, '/99999999', 404, & + '{"erro":"cep_nao_encontrado",'// & + '"mensagem":"CEP nao existe na base do DNE"}', '') + call local_client(client) + + call client%lookup('99999999', address, status, message) + call check(status == CEPIS_ERR_NOT_FOUND, '404 becomes not found') + call check(server_count(server, '/99999999') == 1, '404 is not retried') + call check(len(message) > 0, 'not found explains itself') + end subroutine test_not_found_is_not_retried + + subroutine test_invalid_cep_never_leaves_the_machine() + type(cepis_client) :: client + type(cepis_address) :: address + character(len=:), allocatable :: message + integer :: status + + call server_reset(server) + call local_client(client) + + call client%lookup('123', address, status, message) + call check(status == CEPIS_ERR_INVALID_CEP, 'a short CEP is rejected locally') + call check(server_total(server) == 0, 'no request is made for a bad CEP') + end subroutine test_invalid_cep_never_leaves_the_machine + + subroutine test_api_400_becomes_invalid_cep() + type(cepis_client) :: client + type(cepis_address) :: address + character(len=:), allocatable :: message + integer :: status + + call server_reset(server) + call server_respond(server, '/00000000', 400, & + '{"erro":"cep_invalido","mensagem":"CEP deve ter 8 digitos"}', '') + call local_client(client) + + call client%lookup('00000000', address, status, message) + call check(status == CEPIS_ERR_INVALID_CEP, '400 becomes invalid CEP') + call check(message == 'CEP deve ter 8 digitos', 'the API message is carried through') + call check(server_count(server, '/00000000') == 1, '400 is not retried') + end subroutine test_api_400_becomes_invalid_cep + + subroutine test_response_that_is_not_json() + type(cepis_client) :: client + type(cepis_address) :: address + character(len=:), allocatable :: message + integer :: status + + call server_reset(server) + call server_respond(server, '/01001000', 200, & + '<html><body>captive portal</body></html>', '') + call local_client(client) + + call client%lookup('01001000', address, status, message) + call check(status == CEPIS_ERR_INVALID_RESPONSE, 'HTML is an invalid response') + call check(index(message, 'captive') > 0, 'the body is quoted back for diagnosis') + end subroutine test_response_that_is_not_json + + subroutine test_retries_on_500_then_succeeds() + type(cepis_client) :: client + type(cepis_address) :: address + character(len=:), allocatable :: message + integer :: status + + call server_reset(server) + call server_respond(server, '/01001000', 500, '{"erro":"interno"}', '') + call server_respond_more(server, '/01001000', 200, SE, '') + call local_client(client) + + call client%lookup('01001000', address, status, message) + call check(status == CEPIS_OK, 'a transient 500 is retried') + call check(address%uf == 'SP', 'the retry returns the address') + call check(server_count(server, '/01001000') == 2, 'exactly two attempts were made') + end subroutine test_retries_on_500_then_succeeds + + subroutine test_exhausts_attempts_then_fails() + type(cepis_client) :: client + type(cepis_address) :: address + character(len=:), allocatable :: message + integer :: status, http_status + + call server_reset(server) + call server_respond(server, '/01001000', 502, 'bad gateway', '') + call local_client(client, max_attempts=3) + + call client%lookup('01001000', address, status, message, http_status=http_status) + call check(status == CEPIS_ERR_SERVER, 'exhausted attempts give a server error') + call check(http_status == 502, 'the last HTTP status is exposed') + call check(server_count(server, '/01001000') == 3, 'every attempt was made') + end subroutine test_exhausts_attempts_then_fails + + subroutine test_max_attempts_one_disables_retry() + type(cepis_client) :: client + type(cepis_address) :: address + character(len=:), allocatable :: message + integer :: status + + call server_reset(server) + call server_respond(server, '/01001000', 503, 'unavailable', '') + call local_client(client, max_attempts=1) + + call client%lookup('01001000', address, status, message) + call check(status == CEPIS_ERR_SERVER, 'a single attempt still reports the error') + call check(server_count(server, '/01001000') == 1, 'max_attempts=1 makes one request') + end subroutine test_max_attempts_one_disables_retry + + subroutine test_429_becomes_rate_limited_with_retry_after() + type(cepis_client) :: client + type(cepis_address) :: address + character(len=:), allocatable :: message + integer :: status + real(real64) :: retry_after + + call server_reset(server) + call server_respond(server, '/01001000', 429, 'slow down', 'Retry-After: 2') + call local_client(client, max_attempts=2, backoff_max=0.05_real64) + + call client%lookup('01001000', address, status, message, retry_after=retry_after) + call check(status == CEPIS_ERR_RATE_LIMITED, '429 becomes rate limited') + call check(abs(retry_after - 2.0_real64) < 1.0e-9_real64, & + 'Retry-After is exposed to the caller') + call check(server_count(server, '/01001000') == 2, '429 is retried') + end subroutine test_429_becomes_rate_limited_with_retry_after + + subroutine test_retry_after_http_date_is_understood() + type(cepis_client) :: client + type(cepis_address) :: address + character(len=:), allocatable :: message + integer :: status + real(real64) :: retry_after + + call server_reset(server) + call server_respond(server, '/01001000', 429, 'slow down', & + 'Retry-After: Wed, 21 Oct 2099 07:28:00 GMT') + call local_client(client, max_attempts=2, backoff_max=0.05_real64) + + call client%lookup('01001000', address, status, message, retry_after=retry_after) + call check(status == CEPIS_ERR_RATE_LIMITED, 'a dated 429 is still rate limited') + call check(retry_after > 1.0e9_real64, 'an HTTP-date Retry-After is understood') + end subroutine test_retry_after_http_date_is_understood + + subroutine test_retry_after_honours_the_cap() + type(cepis_client) :: client + type(cepis_address) :: address + character(len=:), allocatable :: message + integer :: status + integer(int64) :: start + + call server_reset(server) + call server_respond(server, '/01001000', 429, 'slow down', 'Retry-After: 3600') + call local_client(client, max_attempts=2, backoff_max=0.05_real64) + + start = now_ticks() + call client%lookup('01001000', address, status, message) + call check(status == CEPIS_ERR_RATE_LIMITED, 'a huge Retry-After still fails cleanly') + call check(elapsed_since(start) < 10.0_real64, & + 'Retry-After is capped at backoff_max') + end subroutine test_retry_after_honours_the_cap + + subroutine test_network_error_when_nothing_listens() + type(cepis_client) :: client + type(cepis_address) :: address + character(len=:), allocatable :: message + integer :: status + + call local_client(client, max_attempts=2, backoff_max=0.01_real64, & + url='http://127.0.0.1:1') + + call client%lookup('01001000', address, status, message) + call check(status == CEPIS_ERR_NETWORK, 'a refused connection is a network error') + call check(len(message) > 0, 'the network error carries libcurl detail') + end subroutine test_network_error_when_nothing_listens + + subroutine test_total_timeout_bounds_the_whole_call() + type(cepis_client) :: client + type(cepis_address) :: address + character(len=:), allocatable :: message + integer :: status + integer(int64) :: start + + call server_reset(server) + call server_respond(server, '/01001000', 500, 'boom', '') + call local_client(client, max_attempts=8, total_timeout=0.4_real64) + client%backoff_base = 1.0_real64 + client%backoff_max = 8.0_real64 + + start = now_ticks() + call client%lookup('01001000', address, status, message) + call check(status == CEPIS_ERR_SERVER, 'the bounded call still reports the error') + call check(elapsed_since(start) < 8.0_real64, 'total_timeout bounds the whole call') + end subroutine test_total_timeout_bounds_the_whole_call + + subroutine test_batch_preserves_order_and_marks_missing() + type(cepis_client) :: client + type(cepis_address), allocatable :: addresses(:) + character(len=:), allocatable :: message + integer :: status + + call server_reset(server) + call server_respond_default(server, 200, CSV_HEADER//char(10)// & + '01001000,Praca da Se,lado impar,,Se,Sao Paulo,SP,'// & + 'Sao Paulo,Sudeste,3550308,1004,11,7107'//char(10)// & + '99999999,,,,,,,,,,,,'//char(10)// & + '20040020,Avenida Rio Branco,,,Centro,Rio de Janeiro,'// & + 'RJ,Rio de Janeiro,Sudeste,3304557,,21,6001'//char(10), '') + call local_client(client) + + call client%lookup_many(['01001000', '99999999', '20040020'], addresses, & + status, message) + call check(status == CEPIS_OK, 'the batch succeeds') + call check(size(addresses) == 3, 'the batch keeps its length') + call check(addresses(1)%found, 'the first CEP resolved') + call check(.not. addresses(2)%found, 'the missing CEP is marked not found') + call check(addresses(2)%cep == '99999999', & + 'the missing CEP keeps its place and its number') + call check(addresses(3)%found, 'the third CEP resolved') + call check(addresses(3)%localidade == 'Rio de Janeiro', & + 'the third CEP is not shifted by the missing one') + call check(.not. addresses(1)%has_geo, 'the batch carries no coordinate') + call check(server_count(server, '/csv') == 1, 'the batch is one request') + end subroutine test_batch_preserves_order_and_marks_missing + + subroutine test_batch_field_with_comma_is_parsed() + type(cepis_client) :: client + type(cepis_address), allocatable :: addresses(:) + character(len=:), allocatable :: message + integer :: status + + call server_reset(server) + call server_respond_default(server, 200, CSV_HEADER//char(10)// & + '01001000,"Rua Um, Dois","de 1 a 99",,Centro,'// & + 'Sao Paulo,SP,Sao Paulo,Sudeste,3550308,1004,11,7107'// & + char(10), '') + call local_client(client) + + call client%lookup_many(['01001000'], addresses, status, message) + call check(status == CEPIS_OK, 'the quoted batch succeeds') + call check(addresses(1)%logradouro == 'Rua Um, Dois', & + 'a comma inside a field is not a separator') + call check(addresses(1)%uf == 'SP', 'the columns after it are still aligned') + end subroutine test_batch_field_with_comma_is_parsed + + subroutine test_batch_empty_list_makes_no_request() + type(cepis_client) :: client + type(cepis_address), allocatable :: addresses(:) + character(len=8), allocatable :: nothing(:) + character(len=:), allocatable :: message + integer :: status + + call server_reset(server) + call local_client(client) + allocate (nothing(0)) + + call client%lookup_many(nothing, addresses, status, message) + call check(status == CEPIS_OK, 'an empty batch succeeds') + call check(size(addresses) == 0, 'an empty batch returns nothing') + call check(server_total(server) == 0, 'an empty batch makes no request') + end subroutine test_batch_empty_list_makes_no_request + + subroutine test_batch_chunks_above_the_api_limit() + type(cepis_client) :: client + type(cepis_address), allocatable :: addresses(:) + character(len=8) :: many(501) + character(len=:), allocatable :: message + character(len=8) :: scratch + integer :: status, i + + call server_reset(server) + call server_respond_default(server, 200, CSV_HEADER//char(10), '') + call local_client(client) + + do i = 1, 501 + write (scratch, '(I8.8)') i + many(i) = scratch + end do + + call client%lookup_many(many, addresses, status, message) + call check(status == CEPIS_OK, 'a batch above the limit succeeds') + call check(size(addresses) == 501, 'the oversized batch keeps its length') + call check(server_count(server, '/csv') == 2, 'the batch is chunked at 500') + call check(occurrences(server_path(server, 1), '%2C') == 499, & + 'the first chunk carries 500 CEPs') + call check(occurrences(server_path(server, 2), '%2C') == 0, & + 'the second chunk carries the remaining one') + end subroutine test_batch_chunks_above_the_api_limit + + subroutine test_batch_truncated_response_does_not_shift() + type(cepis_client) :: client + type(cepis_address), allocatable :: addresses(:) + character(len=:), allocatable :: message + integer :: status + + call server_reset(server) + call server_respond_default(server, 200, CSV_HEADER//char(10)// & + '01001000,Praca da Se,,,Se,Sao Paulo,SP,Sao Paulo,'// & + 'Sudeste,3550308,1004,11,7107'//char(10), '') + call local_client(client) + + call client%lookup_many(['01001000', '20040020', '30140071'], addresses, & + status, message) + call check(status == CEPIS_OK, 'a short response is not an error') + call check(size(addresses) == 3, 'a short response is padded, not returned short') + call check(addresses(1)%found, 'the row that arrived is used') + call check(.not. addresses(2)%found, 'the missing rows are not found') + call check(.not. addresses(3)%found, 'the last missing row is not found') + call check(addresses(3)%cep == '30140071', 'the padded entries keep their CEP') + end subroutine test_batch_truncated_response_does_not_shift + + subroutine test_batch_malformed_cep_is_not_found() + type(cepis_client) :: client + type(cepis_address), allocatable :: addresses(:) + character(len=:), allocatable :: message + integer :: status + + call server_reset(server) + call server_respond_default(server, 200, CSV_HEADER//char(10)// & + 'abc,,,,,,,,,,,,'//char(10)// & + '01001000,Praca da Se,,,Se,Sao Paulo,SP,Sao Paulo,'// & + 'Sudeste,3550308,1004,11,7107'//char(10), '') + call local_client(client) + + call client%lookup_many(['abc ', '01001000'], addresses, status, message) + call check(status == CEPIS_OK, 'a malformed CEP does not fail the batch') + call check(.not. addresses(1)%found, 'a malformed CEP is simply not found') + call check(addresses(2)%found, 'the rest of the batch still resolves') + end subroutine test_batch_malformed_cep_is_not_found + + subroutine test_batch_retries_on_503() + type(cepis_client) :: client + type(cepis_address), allocatable :: addresses(:) + character(len=:), allocatable :: message + integer :: status + + call server_reset(server) + call server_respond_default(server, 503, 'unavailable', '') + call local_client(client, max_attempts=2) + + call client%lookup_many(['01001000'], addresses, status, message) + call check(status == CEPIS_ERR_SERVER, 'a batch 503 is a server error') + call check(server_count(server, '/csv') == 2, 'the batch retries on 503') + end subroutine test_batch_retries_on_503 + + subroutine test_health() + type(cepis_client) :: client + type(cepis_health) :: health + character(len=:), allocatable :: message + integer :: status + + call server_reset(server) + call server_respond(server, '/health', 200, HEALTH_BODY, '') + call local_client(client) + + call client%health(health, status, message) + call check(status == CEPIS_OK, 'health succeeds') + call check(health%ok(), 'health reports ok') + call check(health%dne == '26071', 'health carries the database identifier') + call check(health%ceps == 1596168_int64, 'health counts the CEPs') + call check(health%geo == 894489_int64, 'health counts the coordinates') + call check(health%base_gerada_em == '2026-07-24T03:48:28Z', 'health dates the base') + end subroutine test_health + + subroutine test_health_degraded_does_not_fail() + type(cepis_client) :: client + type(cepis_health) :: health + character(len=:), allocatable :: message + integer :: status + + call server_reset(server) + call server_respond(server, '/health', 503, & + '{"status":"degraded","dne":"26071","ceps":0,"geo":0,'// & + '"base_gerada_em":""}', '') + call local_client(client, max_attempts=3) + + call client%health(health, status, message) + call check(status == CEPIS_OK, 'a degraded API is not an error') + call check(.not. health%ok(), 'the degradation arrives in status') + call check(health%status == 'degraded', 'the reported status is carried through') + call check(server_count(server, '/health') == 1, 'a 503 from health is not retried') + end subroutine test_health_degraded_does_not_fail + + subroutine test_trailing_slash_is_not_duplicated() + type(cepis_client) :: client + type(cepis_address) :: address + character(len=:), allocatable :: message + integer :: status + + call server_reset(server) + call server_respond(server, '/01001000', 200, SE, '') + call local_client(client, url=base//'///') + + call client%lookup('01001000', address, status, message) + call check(status == CEPIS_OK, 'a trailing slash in base_url still works') + call check(server_path(server, 1) == '/01001000', 'the path has no doubled separator') + end subroutine test_trailing_slash_is_not_duplicated + + subroutine test_invalid_configuration_is_rejected() + type(cepis_client) :: client + character(len=:), allocatable :: message + integer :: status + + call cepis_client_init(client, status, message, max_attempts=0) + call check(status == CEPIS_ERR_CONFIG, 'max_attempts below one is rejected') + + call cepis_client_init(client, status, message, timeout=0.0_real64) + call check(status == CEPIS_ERR_CONFIG, 'a zero timeout is rejected') + + call cepis_client_init(client, status, message, base_url=' ') + call check(status == CEPIS_ERR_CONFIG, 'an empty base_url is rejected') + + call cepis_client_init(client, status, message) + call check(status == CEPIS_OK, 'the defaults are valid') + call check(client%url() == CEPIS_DEFAULT_BASE_URL, 'the default base_url is cep.is') + end subroutine test_invalid_configuration_is_rejected + + subroutine test_user_agent_identifies_the_library() + type(cepis_client) :: client + character(len=:), allocatable :: message + integer :: status + + call cepis_client_init(client, status, message) + call check(index(client%agent(), 'cepis-fortran/') > 0, & + 'the user agent names the library') + call check(index(client%agent(), CEPIS_VERSION) > 0, & + 'the user agent carries the version') + end subroutine test_user_agent_identifies_the_library + + subroutine test_status_names_exist() + call check(cepis_status_name(CEPIS_OK) == 'ok', 'ok has a name') + call check(cepis_status_name(CEPIS_ERR_NOT_FOUND) == 'not_found', & + 'not found has a name') + call check(cepis_status_name(CEPIS_ERR_INVALID_RESPONSE) == 'invalid_response', & + 'invalid response has a name') + call check(cepis_status_name(-1) == 'unknown', 'an unknown code has a name') + end subroutine test_status_names_exist + +end program test_cepis diff --git a/test/test_server.f90 b/test/test_server.f90 new file mode 100644 index 0000000..bb8cb0c --- /dev/null +++ b/test/test_server.f90 @@ -0,0 +1,214 @@ +!> Fortran side of the suite's local HTTP server. +!> +!> The server itself is `test/http_server.c`, compiled and linked with the +!> tests. Everything here is a thin `iso_c_binding` wrapper that takes and +!> returns ordinary Fortran strings. +module test_server + use, intrinsic :: iso_c_binding + use cepis_strings, only: to_c_chars, from_integer + use, intrinsic :: iso_fortran_env, only: int64 + implicit none + private + + public :: server_start + public :: server_stop + public :: server_reset + public :: server_base_url + public :: server_respond + public :: server_respond_more + public :: server_respond_default + public :: server_count + public :: server_total + public :: server_path + + interface + function ts_start() bind(c, name='ts_start') result(handle) + import :: c_ptr + type(c_ptr) :: handle + end function ts_start + + subroutine ts_stop(handle) bind(c, name='ts_stop') + import :: c_ptr + type(c_ptr), value :: handle + end subroutine ts_stop + + subroutine ts_reset(handle) bind(c, name='ts_reset') + import :: c_ptr + type(c_ptr), value :: handle + end subroutine ts_reset + + function ts_port(handle) bind(c, name='ts_port') result(port) + import :: c_ptr, c_int + type(c_ptr), value :: handle + integer(c_int) :: port + end function ts_port + + subroutine ts_respond(handle, path, status, body, headers) & + bind(c, name='ts_respond') + import :: c_ptr, c_char, c_long + type(c_ptr), value :: handle + character(kind=c_char), intent(in) :: path(*) + integer(c_long), value :: status + character(kind=c_char), intent(in) :: body(*) + character(kind=c_char), intent(in) :: headers(*) + end subroutine ts_respond + + subroutine ts_respond_more(handle, path, status, body, headers) & + bind(c, name='ts_respond_more') + import :: c_ptr, c_char, c_long + type(c_ptr), value :: handle + character(kind=c_char), intent(in) :: path(*) + integer(c_long), value :: status + character(kind=c_char), intent(in) :: body(*) + character(kind=c_char), intent(in) :: headers(*) + end subroutine ts_respond_more + + subroutine ts_respond_default(handle, status, body, headers) & + bind(c, name='ts_respond_default') + import :: c_ptr, c_char, c_long + type(c_ptr), value :: handle + integer(c_long), value :: status + character(kind=c_char), intent(in) :: body(*) + character(kind=c_char), intent(in) :: headers(*) + end subroutine ts_respond_default + + function ts_count(handle, prefix) bind(c, name='ts_count') result(total) + import :: c_ptr, c_char, c_size_t + type(c_ptr), value :: handle + character(kind=c_char), intent(in) :: prefix(*) + integer(c_size_t) :: total + end function ts_count + + function ts_total(handle) bind(c, name='ts_total') result(total) + import :: c_ptr, c_size_t + type(c_ptr), value :: handle + integer(c_size_t) :: total + end function ts_total + + function ts_path_length(handle, index) bind(c, name='ts_path_length') result(length) + import :: c_ptr, c_size_t + type(c_ptr), value :: handle + integer(c_size_t), value :: index + integer(c_size_t) :: length + end function ts_path_length + + subroutine ts_path_copy(handle, index, out, out_size) & + bind(c, name='ts_path_copy') + import :: c_ptr, c_char, c_size_t + type(c_ptr), value :: handle + integer(c_size_t), value :: index + character(kind=c_char), intent(inout) :: out(*) + integer(c_size_t), value :: out_size + end subroutine ts_path_copy + end interface + +contains + + !> Start a server on a random loopback port. `c_null_ptr` on failure. + function server_start() result(handle) + type(c_ptr) :: handle + + handle = ts_start() + end function server_start + + subroutine server_stop(handle) + type(c_ptr), intent(in) :: handle + + call ts_stop(handle) + end subroutine server_stop + + !> Forget every route and every recorded request. + subroutine server_reset(handle) + type(c_ptr), intent(in) :: handle + + call ts_reset(handle) + end subroutine server_reset + + !> `http://127.0.0.1:PORT`. + function server_base_url(handle) result(url) + type(c_ptr), intent(in) :: handle + character(len=:), allocatable :: url + + url = 'http://127.0.0.1:'//from_integer(int(ts_port(handle), int64)) + end function server_base_url + + !> Register the only reply for `path`, replacing any previous route. + subroutine server_respond(handle, path, status, body, headers) + type(c_ptr), intent(in) :: handle + character(len=*), intent(in) :: path + integer, intent(in) :: status + character(len=*), intent(in) :: body + character(len=*), intent(in) :: headers + + call ts_respond(handle, to_c_chars(path), int(status, c_long), & + to_c_chars(body), to_c_chars(headers)) + end subroutine server_respond + + !> Append another reply to `path`. Each request consumes the next entry; + !> the last one repeats once the queue runs out. This is how retrying is + !> tested. + subroutine server_respond_more(handle, path, status, body, headers) + type(c_ptr), intent(in) :: handle + character(len=*), intent(in) :: path + integer, intent(in) :: status + character(len=*), intent(in) :: body + character(len=*), intent(in) :: headers + + call ts_respond_more(handle, to_c_chars(path), int(status, c_long), & + to_c_chars(body), to_c_chars(headers)) + end subroutine server_respond_more + + !> The reply for any path with no explicit route. Used where the request + !> path is thousands of characters long and matching it buys nothing. + subroutine server_respond_default(handle, status, body, headers) + type(c_ptr), intent(in) :: handle + integer, intent(in) :: status + character(len=*), intent(in) :: body + character(len=*), intent(in) :: headers + + call ts_respond_default(handle, int(status, c_long), to_c_chars(body), & + to_c_chars(headers)) + end subroutine server_respond_default + + !> How many requests so far had a path starting with `prefix`. + function server_count(handle, prefix) result(total) + type(c_ptr), intent(in) :: handle + character(len=*), intent(in) :: prefix + integer :: total + + total = int(ts_count(handle, to_c_chars(prefix))) + end function server_count + + !> How many requests the server has served in total. + function server_total(handle) result(total) + type(c_ptr), intent(in) :: handle + integer :: total + + total = int(ts_total(handle)) + end function server_total + + !> The path of request `index`, counting from one. Empty when there is no + !> such request. + function server_path(handle, index) result(path) + type(c_ptr), intent(in) :: handle + integer, intent(in) :: index + character(len=:), allocatable :: path + character(kind=c_char), allocatable :: buffer(:) + integer :: length, i + + length = int(ts_path_length(handle, int(index - 1, c_size_t))) + if (length <= 0) then + path = '' + return + end if + + allocate (buffer(length + 1)) + call ts_path_copy(handle, int(index - 1, c_size_t), buffer, & + int(length + 1, c_size_t)) + allocate (character(len=length) :: path) + do i = 1, length + path(i:i) = buffer(i) + end do + end function server_path + +end module test_server |