diff options
| -rw-r--r-- | .fprettify.rc | 3 | ||||
| -rw-r--r-- | .gitignore | 12 | ||||
| -rw-r--r-- | LICENSE | 15 | ||||
| -rw-r--r-- | Makefile | 140 | ||||
| -rw-r--r-- | README.md | 259 | ||||
| -rw-r--r-- | app/main.f90 | 159 | ||||
| -rw-r--r-- | src/cepis.f90 | 693 | ||||
| -rw-r--r-- | src/cepis_csv.f90 | 218 | ||||
| -rw-r--r-- | src/cepis_errors.f90 | 83 | ||||
| -rw-r--r-- | src/cepis_http.f90 | 477 | ||||
| -rw-r--r-- | src/cepis_json.f90 | 635 | ||||
| -rw-r--r-- | src/cepis_models.f90 | 289 | ||||
| -rw-r--r-- | src/cepis_strings.f90 | 347 | ||||
| -rw-r--r-- | test/http_server.c | 461 | ||||
| -rw-r--r-- | test/test_cepis.f90 | 886 | ||||
| -rw-r--r-- | test/test_server.f90 | 214 |
16 files changed, 4891 insertions, 0 deletions
diff --git a/.fprettify.rc b/.fprettify.rc new file mode 100644 index 0000000..27ac8b6 --- /dev/null +++ b/.fprettify.rc @@ -0,0 +1,3 @@ +indent=4 +line-length=100 +whitespace=2 diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..590ba82 --- /dev/null +++ b/.gitignore @@ -0,0 +1,12 @@ +build/ +*.o +*.a +*.so +*.so.* +*.mod +*.smod +*.gcda +*.gcno +*.gcov +core +vgcore.* @@ -0,0 +1,15 @@ +ISC License + +Copyright (c) 2026 Murilo Ijanc <[email protected]> + +Permission to use, copy, modify, and/or distribute this software for any +purpose with or without fee is hereby granted, provided that the above +copyright notice and this permission notice appear in all copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH +REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY +AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, +INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM +LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR +OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR +PERFORMANCE OF THIS SOFTWARE. diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..e649642 --- /dev/null +++ b/Makefile @@ -0,0 +1,140 @@ +VERSION := 0.1.0 + +ifeq ($(origin FC),default) +FC := gfortran +endif +FC ?= gfortran +CC ?= cc +AR ?= ar +FPRETTIFY ?= fprettify +PREFIX ?= /usr/local +LIBDIR ?= $(PREFIX)/lib +INCLUDEDIR ?= $(PREFIX)/include/cepis +BINDIR ?= $(PREFIX)/bin + +BUILD := build + +CURL_CFLAGS := $(shell pkg-config --cflags libcurl 2>/dev/null) +CURL_LIBS := $(shell pkg-config --libs libcurl 2>/dev/null || echo -lcurl) + +WARNINGS := -Wall -Wextra -Wno-unused-dummy-argument +SAN := -fsanitize=address,undefined -fno-omit-frame-pointer +FFLAGS ?= -O2 -g +FFLAGS += -std=f2018 -fimplicit-none -J$(BUILD) -I$(BUILD) $(WARNINGS) $(EXTRA_FFLAGS) +CFLAGS ?= -O2 -g +CFLAGS += -std=c11 -D_POSIX_C_SOURCE=200809L -Wall -Wextra $(EXTRA_CFLAGS) +LDFLAGS += $(EXTRA_LDFLAGS) +LDLIBS += $(CURL_LIBS) + +LIB_SRC := src/cepis_errors.f90 src/cepis_strings.f90 src/cepis_json.f90 \ + src/cepis_csv.f90 src/cepis_http.f90 src/cepis_models.f90 \ + src/cepis.f90 +LIB_OBJ := $(LIB_SRC:%.f90=$(BUILD)/%.o) +LIB_MOD := $(BUILD)/cepis.mod $(BUILD)/cepis_errors.mod \ + $(BUILD)/cepis_strings.mod $(BUILD)/cepis_json.mod \ + $(BUILD)/cepis_csv.mod $(BUILD)/cepis_http.mod \ + $(BUILD)/cepis_models.mod + +ALL_F90 := $(LIB_SRC) test/test_server.f90 app/main.f90 test/test_cepis.f90 + +STATIC := $(BUILD)/libcepis.a +CLI := $(BUILD)/cepis +TESTS := $(BUILD)/test_cepis + +.DEFAULT_GOAL := help +.PHONY: help build test lint format check sanitize clean install uninstall + +help: + @echo 'Targets:' + @echo ' build static library, modules and the cepis CLI' + @echo ' test build and run the suite against a local HTTP server' + @echo ' lint strict warning-free rebuild + fprettify --diff (read-only)' + @echo ' format apply fprettify (writes)' + @echo ' check lint, then test, then build' + @echo ' sanitize rebuild and run the suite under ASan + UBSan' + @echo ' install install modules, the library and the CLI under PREFIX' + @echo ' clean remove $(BUILD)/' + @echo + @echo 'Requires gfortran (or another Fortran 2018 compiler), a C compiler' + @echo 'and libcurl with its development headers.' + @echo 'Override the compiler with e.g. make test FC=flang' + +build: $(STATIC) $(CLI) + +$(BUILD)/%.o: %.f90 + @mkdir -p $(dir $@) $(BUILD) + $(FC) $(FFLAGS) -c $< -o $@ + +$(BUILD)/%.o: %.c + @mkdir -p $(dir $@) + $(CC) $(CFLAGS) $(CURL_CFLAGS) -c $< -o $@ + +$(BUILD)/src/cepis_json.o: $(BUILD)/src/cepis_strings.o +$(BUILD)/src/cepis_csv.o: $(BUILD)/src/cepis_strings.o +$(BUILD)/src/cepis_http.o: $(BUILD)/src/cepis_strings.o +$(BUILD)/src/cepis_models.o: $(BUILD)/src/cepis_json.o $(BUILD)/src/cepis_strings.o +$(BUILD)/src/cepis.o: $(BUILD)/src/cepis_errors.o $(BUILD)/src/cepis_strings.o \ + $(BUILD)/src/cepis_json.o $(BUILD)/src/cepis_csv.o \ + $(BUILD)/src/cepis_http.o $(BUILD)/src/cepis_models.o +$(BUILD)/app/main.o: $(BUILD)/src/cepis.o +$(BUILD)/test/test_server.o: $(BUILD)/src/cepis_strings.o +$(BUILD)/test/test_cepis.o: $(BUILD)/src/cepis.o $(BUILD)/test/test_server.o + +$(STATIC): $(LIB_OBJ) + @mkdir -p $(dir $@) + $(AR) rcs $@ $(LIB_OBJ) + +$(CLI): $(BUILD)/app/main.o $(STATIC) + $(FC) $(FFLAGS) $(BUILD)/app/main.o $(STATIC) $(LDFLAGS) $(LDLIBS) -o $@ + +$(TESTS): $(BUILD)/test/test_cepis.o $(BUILD)/test/test_server.o \ + $(BUILD)/test/http_server.o $(STATIC) + $(FC) $(FFLAGS) $(BUILD)/test/test_cepis.o $(BUILD)/test/test_server.o \ + $(BUILD)/test/http_server.o $(STATIC) $(LDFLAGS) $(LDLIBS) -lpthread -o $@ + +test: $(TESTS) + $(TESTS) + +# Read-only by design, so it is safe in CI and in a pre-commit hook. The +# rebuild turns every warning into an error without touching the ordinary +# build tree; fprettify only reports, and is skipped when it is not installed. +lint: + @rm -rf $(BUILD)/lint + @mkdir -p $(BUILD)/lint + $(FC) -std=f2018 -fimplicit-none $(WARNINGS) -Werror -fsyntax-only \ + -J$(BUILD)/lint -I$(BUILD)/lint $(ALL_F90) + $(CC) $(CFLAGS) $(CURL_CFLAGS) -Werror -fsyntax-only test/http_server.c + @if command -v $(FPRETTIFY) >/dev/null 2>&1; then \ + $(FPRETTIFY) --diff --indent 4 --line-length 100 $(ALL_F90); \ + else \ + echo 'fprettify not installed: skipping style check'; \ + fi + +format: + $(FPRETTIFY) --indent 4 --line-length 100 $(ALL_F90) + +# The order matters: lint is the fastest to fail, build the slowest, so a +# broken run reports the cheapest problem first. +check: lint test build + +# Rebuilt from scratch: the sanitizers change the ABI of the objects, so they +# must not be mixed with objects from an ordinary build. +sanitize: + $(MAKE) clean + $(MAKE) test EXTRA_FFLAGS='$(SAN) -fcheck=all' EXTRA_CFLAGS='$(SAN)' \ + EXTRA_LDFLAGS='$(SAN)' + $(MAKE) clean + +install: build + install -d $(DESTDIR)$(INCLUDEDIR) $(DESTDIR)$(LIBDIR) $(DESTDIR)$(BINDIR) + install -m 644 $(LIB_MOD) $(DESTDIR)$(INCLUDEDIR)/ + install -m 644 $(STATIC) $(DESTDIR)$(LIBDIR)/ + install -m 755 $(CLI) $(DESTDIR)$(BINDIR)/ + +uninstall: + rm -rf $(DESTDIR)$(INCLUDEDIR) + rm -f $(DESTDIR)$(LIBDIR)/libcepis.a + rm -f $(DESTDIR)$(BINDIR)/cepis + +clean: + rm -rf $(BUILD) diff --git a/README.md b/README.md new file mode 100644 index 0000000..6ccea02 --- /dev/null +++ b/README.md @@ -0,0 +1,259 @@ +# cepis + +Fortran client for the [public CEP API at cep.is](https://cep.is). Official +Correios data (DNE), refreshed every two weeks. + +```fortran +program demo + use cepis + implicit none + + type(cepis_address) :: address + character(len=:), allocatable :: message + integer :: status + + call cepis_lookup('01001-000', address, status, message) + if (status == CEPIS_OK) then + print *, address%logradouro, address%localidade, address%uf + end if +end program demo +``` + +## Installation + +There is no package manager here. Build the static library and link it: + +```sh +git clone https://git.cep.is/fortran.git cepis-fortran +cd cepis-fortran +make build +sudo make install # modules under $PREFIX/include/cepis, libcepis.a under $PREFIX/lib +``` + +```sh +gfortran -I/usr/local/include/cepis demo.f90 -L/usr/local/lib -lcepis -lcurl -o demo +``` + +Requires **Fortran 2018** (gfortran 9 or newer), a C compiler, and **libcurl +with its development headers** — `libcurl4-openssl-dev` on Debian and Ubuntu, +`curl-devel` on Fedora, `curl` on Alpine and OpenBSD. Fortran has no HTTP +client and no sockets, so the transport is libcurl bound through +`iso_c_binding`; the interface blocks are written by hand in +`src/cepis_http.f90` rather than vendoring a third-party Fortran-curl wrapper, +because the twelve entry points this library needs are a fraction of what such +a wrapper brings, and one file with no dependency is easier to audit than one +more dependency. + +## Usage + +`use cepis` brings in everything. Every fallible call returns an `integer` +status and an allocatable `message`; nothing stops the program. + +### A single lookup + +`lookup` accepts the CEP masked or unmasked: + +```fortran +type(cepis_address) :: a +character(len=:), allocatable :: message +integer :: status + +call cepis_lookup('01310100', a, status, message) + +a%logradouro ! 'Avenida Paulista' +a%localidade ! 'São Paulo' +a%uf ! 'SP' +a%ibge ! '3550308' +a%cep ! '01310100' (always unmasked) +a%formatted_cep() ! '01310-100' +``` + +Fields the database does not have for that CEP come back as empty strings. +Every character component is allocated after a successful call, so none of them +needs an `allocated` check. + +### Coordinates + +About 57% of CEPs have a coordinate. `has_geo` says whether this one does: + +```fortran +if (a%has_geo) then + print *, a%geo%lat, a%geo%lon ! -23.567202 -46.649659 + print *, a%geo%raio_m ! 1084 + print *, a%geo%precisao ! 'logradouro' +end if +``` + +**Check `precisao` before computing distance.** There are two kinds of point, +and the difference between them is tens of kilometres: + +| `precisao` | typical radius | what the point is | +| --- | --- | --- | +| `logradouro` | 110–140 m | the stretch of street — good for maps and distance | +| `localidade` | 7–40 km | the municipality centroid: the CEP *is* the whole city | + +`a%geo%is_precise()` is the shorthand for `precisao == 'logradouro'`: + +```fortran +if (a%has_geo .and. a%geo%is_precise()) then + call shipping_from(a%geo%lat, a%geo%lon) +else + call shipping_from_municipality(a%ibge) +end if +``` + +### Many CEPs at once + +Do not loop over `lookup`. Use `lookup_many`, which resolves up to 500 CEPs per +request: + +```fortran +type(cepis_address), allocatable :: found(:) +character(len=8) :: ceps(3) = ['01001000', '99999999', '20040020'] +integer :: i + +call cepis_lookup_many(ceps, found, status, message) + +do i = 1, size(found) + if (found(i)%found) then + print *, ceps(i), found(i)%localidade + else + print *, ceps(i), 'not found' + end if +end do +``` + +The result has **the same length and the same order** as the input. A CEP that +does not exist, or is malformed, has `found = .false.` at its position — it does +not vanish, and it is not an error. Trailing blanks in each element are ignored, +so a fixed-length array literal works as written. + +Lists longer than 500 are chunked automatically. + +> **Batches carry no coordinate.** The endpoint behind them is CSV, and the CSV +> has no `geo` column. Every address from `lookup_many` has `has_geo = .false.`, +> including for CEPs that do have one. Need `geo`? Use `lookup`, one at a time. + +### API health + +Useful for two things: checking the API answers, and knowing **which version of +the database** is live: + +```fortran +type(cepis_health) :: h + +call cepis_check_health(h, status, message) + +h%ok() ! .true. +h%dne ! '26071' identifier of the fortnightly database +h%ceps ! 1596168 +h%base_gerada_em ! '2026-07-24T03:48:28Z' +``` + +An API reporting itself degraded is not an error — that arrives in `h%status`. + +### From the command line + +`make build` also produces `build/cepis`: + +```sh +build/cepis 01001000 +build/cepis --base-url http://localhost:8080 01001000 20040020 +build/cepis --health +``` + +## Configuration + +For anything beyond the defaults, build a `cepis_client` and reuse it. It keeps +no state between calls: + +```fortran +type(cepis_client) :: client + +call cepis_client_init(client, status, message, & + base_url='https://cep.is', & ! point at another instance + timeout=10.0d0, & ! seconds per socket operation + max_attempts=3, & ! counting the first; 1 disables retrying + backoff_base=0.5d0, & ! base of the exponential wait + backoff_max=8.0d0, & ! cap on each wait, Retry-After included + total_timeout=0.0d0) ! cap on the whole call; 0 means none + +call client%lookup('01001000', address, status, message) +``` + +Every argument after `message` is optional. Retries cover 429, 5xx and network +failures, with exponential backoff and jitter; 400 and 404 are never retried. + +`lookup`, `lookup_many` and `health` also accept two optional `intent(out)` +arguments, `http_status` and `retry_after`, for callers that want to reschedule +rate-limited work. + +The module-level `cepis_lookup`, `cepis_lookup_many` and `cepis_check_health` +use one shared default client pointed at `https://cep.is`. It is not safe to use +from two threads at once; build your own client per thread if you need that. + +### Pointing at a local instance + +`base_url` is the only setting that usually changes between environments. The +API repo brings a local instance up with `just up`: + +```fortran +call cepis_client_init(client, status, message, base_url='http://localhost:8080') +``` + +## Errors + +`status` is one of these. The split is by **the decision you have to make**, not +by the HTTP status that caused it: + +| status | when | does retrying help? | +| --- | --- | --- | +| `CEPIS_OK` | the call succeeded | — | +| `CEPIS_ERR_INVALID_CEP` | not 8 digits | no | +| `CEPIS_ERR_NOT_FOUND` | well-formed, not in the database | no | +| `CEPIS_ERR_RATE_LIMITED` | 429 | yes, later | +| `CEPIS_ERR_SERVER` | 5xx | yes, later | +| `CEPIS_ERR_NETWORK` | DNS, connection, timeout, TLS | yes, later | +| `CEPIS_ERR_INVALID_RESPONSE` | unintelligible response | probably not | +| `CEPIS_ERR_CONFIG` | a configuration value is out of range | no | + +```fortran +call cepis_lookup(cep_from_form, address, status, message) +select case (status) +case (CEPIS_OK) + call use_it(address) +case (CEPIS_ERR_NOT_FOUND, CEPIS_ERR_INVALID_CEP) + call ask_again() +case default + call reschedule() ! transient failure +end select +``` + +`cepis_status_name(status)` gives a short, stable English name for logging. + +`CEPIS_ERR_INVALID_RESPONSE` almost always means something between you and the +API is answering instead of it — a captive Wi-Fi portal, a corporate proxy, an +HTML error page. Useful as a diagnosis: the problem is not in your code. + +## Development + +```sh +make # list the targets +make test # build and run the suite against a local HTTP server +make lint # warning-free rebuild + fprettify --diff, touches nothing +make format # apply fprettify (writes) +make build # libcepis.a, the modules and the cepis CLI +make check # lint, then test, then build +make sanitize # rebuild and run the suite under ASan + UBSan +``` + +The suite starts a real HTTP server on a loopback port (`test/http_server.c`, +compiled with the tests) and points `base_url` at it, so nothing is mocked. +`make lint` and `make format` need [fprettify]; `lint` skips the style check +when it is not installed. + +[fprettify]: https://github.com/fortran-lang/fprettify + +## Licence + +ISC. See [LICENSE](LICENSE). diff --git a/app/main.f90 b/app/main.f90 new file mode 100644 index 0000000..5e3f988 --- /dev/null +++ b/app/main.f90 @@ -0,0 +1,159 @@ +!> A one-shot command-line front end, useful for confirming that an instance +!> answers: `cepis --base-url http://localhost:8080 01001000`. +program main + use, intrinsic :: iso_fortran_env, only: real64, output_unit, error_unit + use cepis + implicit none + + character(len=:), allocatable :: url, message + character(len=:), allocatable :: ceps(:) + type(cepis_client) :: client + integer :: status + logical :: want_health + + call parse_arguments(url, ceps, want_health) + + if (len(url) > 0) then + call cepis_client_init(client, status, message, base_url=url) + else + call cepis_client_init(client, status, message) + end if + if (status /= CEPIS_OK) then + write (error_unit, '(A)') 'cepis: '//message + stop 2 + end if + + if (want_health) then + call show_health(client) + else if (size(ceps) == 1) then + call show_one(client, trim(ceps(1))) + else + call show_many(client, ceps) + end if + +contains + + subroutine usage() + write (error_unit, '(A)') 'usage: cepis [--base-url URL] CEP [CEP ...]' + write (error_unit, '(A)') ' cepis [--base-url URL] --health' + stop 2 + end subroutine usage + + subroutine parse_arguments(base, values, health) + character(len=:), allocatable, intent(out) :: base + character(len=:), allocatable, intent(out) :: values(:) + logical, intent(out) :: health + character(len=4096) :: argument + character(len=64) :: collected(256) + integer :: count, i, length, total + + base = '' + health = .false. + count = 0 + total = command_argument_count() + + i = 1 + do while (i <= total) + call get_command_argument(i, argument, length) + if (argument(1:length) == '--health') then + health = .true. + else if (argument(1:length) == '--base-url') then + i = i + 1 + if (i > total) call usage() + call get_command_argument(i, argument, length) + base = argument(1:length) + else if (argument(1:length) == '--help' .or. argument(1:length) == '-h') then + call usage() + else + if (count >= size(collected)) call usage() + count = count + 1 + collected(count) = argument(1:min(length, len(collected))) + end if + i = i + 1 + end do + + if (.not. health .and. count == 0) call usage() + + allocate (character(len=64) :: values(count)) + do i = 1, count + values(i) = collected(i) + end do + end subroutine parse_arguments + + subroutine show_health(handle) + type(cepis_client), intent(in) :: handle + type(cepis_health) :: report + integer :: code + character(len=:), allocatable :: detail + + call handle%health(report, code, detail) + if (code /= CEPIS_OK) then + write (error_unit, '(A)') 'cepis: '//cepis_status_name(code)//': '//detail + stop 1 + end if + + write (output_unit, '(A)') 'status '//report%status + write (output_unit, '(A)') 'dne '//report%dne + write (output_unit, '(A,I0)') 'ceps ', report%ceps + write (output_unit, '(A,I0)') 'geo ', report%geo + write (output_unit, '(A)') 'base_gerada_em '//report%base_gerada_em + end subroutine show_health + + subroutine show_one(handle, cep) + type(cepis_client), intent(in) :: handle + character(len=*), intent(in) :: cep + type(cepis_address) :: address + integer :: code + character(len=:), allocatable :: detail + + call handle%lookup(cep, address, code, detail) + if (code /= CEPIS_OK) then + write (error_unit, '(A)') 'cepis: '//cepis_status_name(code)//': '//detail + stop 1 + end if + + write (output_unit, '(A)') 'cep '//address%formatted_cep() + write (output_unit, '(A)') 'logradouro '//address%logradouro + write (output_unit, '(A)') 'complemento '//address%complemento + write (output_unit, '(A)') 'unidade '//address%unidade + write (output_unit, '(A)') 'bairro '//address%bairro + write (output_unit, '(A)') 'localidade '//address%localidade + write (output_unit, '(A)') 'uf '//address%uf + write (output_unit, '(A)') 'estado '//address%estado + write (output_unit, '(A)') 'regiao '//address%regiao + write (output_unit, '(A)') 'ibge '//address%ibge + write (output_unit, '(A)') 'gia '//address%gia + write (output_unit, '(A)') 'ddd '//address%ddd + write (output_unit, '(A)') 'siafi '//address%siafi + if (address%has_geo) then + write (output_unit, '(A,F0.6,A,F0.6,A,I0,A)') 'geo ', & + address%geo%lat, ', ', address%geo%lon, ' (', address%geo%raio_m, & + ' m, '//address%geo%precisao//')' + end if + end subroutine show_one + + subroutine show_many(handle, values) + type(cepis_client), intent(in) :: handle + character(len=*), intent(in) :: values(:) + type(cepis_address), allocatable :: addresses(:) + integer :: code, i + character(len=:), allocatable :: detail + + call handle%lookup_many(values, addresses, code, detail) + if (code /= CEPIS_OK) then + write (error_unit, '(A)') 'cepis: '//cepis_status_name(code)//': '//detail + stop 1 + end if + + do i = 1, size(addresses) + if (addresses(i)%found) then + write (output_unit, '(A)') trim(values(i))//' '// & + addresses(i)%localidade//'/'//addresses(i)%uf//' '// & + addresses(i)%logradouro + else + write (output_unit, '(A)') trim(values(i))//' not found' + end if + end do + end subroutine show_many + +end program main diff --git a/src/cepis.f90 b/src/cepis.f90 new file mode 100644 index 0000000..27e2c6d --- /dev/null +++ b/src/cepis.f90 @@ -0,0 +1,693 @@ +!> Fortran client for the public CEP API at https://cep.is +!> +!> Official Correios data (DNE), refreshed every two weeks. +!> +!> ```fortran +!> use cepis +!> type(cepis_address) :: address +!> integer :: status +!> character(len=:), allocatable :: message +!> +!> call cepis_lookup('01001-000', address, status, message) +!> if (status == CEPIS_OK) print *, address%logradouro, address%uf +!> ``` +!> +!> Every fallible call reports through `status` and `message` rather than +!> stopping the program. `status` is one of the `CEPIS_*` parameters in +!> `cepis_errors`; `message` is always allocated. +!> +!> A `cepis_client` holds the configuration and keeps no state between calls. +!> The module-level `cepis_lookup`, `cepis_lookup_many` and +!> `cepis_check_health` use one shared default client, which is not safe to use +!> from two threads at once — build your own client per thread if you need +!> that. +module cepis + use, intrinsic :: iso_fortran_env, only: real64, int64 + use cepis_errors + use cepis_strings, only: url_encode, strip, from_integer + use cepis_json, only: json_document, json_parse, JSON_OBJECT + use cepis_csv, only: csv_table, csv_parse + use cepis_http, only: http_response, http_get, http_sleep, http_monotonic + use cepis_models + implicit none + private + + public :: CEPIS_OK + public :: CEPIS_ERR_INVALID_CEP + public :: CEPIS_ERR_NOT_FOUND + public :: CEPIS_ERR_RATE_LIMITED + public :: CEPIS_ERR_SERVER + public :: CEPIS_ERR_NETWORK + public :: CEPIS_ERR_INVALID_RESPONSE + public :: CEPIS_ERR_CONFIG + public :: cepis_status_name + + public :: cepis_geo + public :: cepis_address + public :: cepis_health + public :: cepis_client + + public :: cepis_client_init + public :: cepis_lookup + public :: cepis_lookup_many + public :: cepis_check_health + public :: cepis_normalize_cep + public :: cepis_format_cep + + !> Library version. + character(len=*), parameter, public :: CEPIS_VERSION = '0.1.0' + + !> Default API endpoint. + character(len=*), parameter, public :: CEPIS_DEFAULT_BASE_URL = 'https://cep.is' + + !> Most CEPs the API accepts in one batch request. + integer, parameter, public :: CEPIS_MAX_BATCH = 500 + + character(len=*), parameter :: ACCEPT_HEADER = 'application/json, text/csv;q=0.9, */*;q=0.1' + + !> Client for the cep.is API. + !> + !> A default-initialised `type(cepis_client)` is already usable and talks to + !> `https://cep.is`. Use `cepis_client_init` to change anything, which also + !> validates the values. + type :: cepis_client + !> Where the API lives. Point it at a local instance or at a test + !> server. It is the only setting that usually changes between + !> environments. A trailing slash is stripped, so it cannot produce + !> doubled separators that some proxies normalise and others 404. + character(len=:), allocatable :: base_url + !> Overrides the `User-Agent`. The default identifies the library and + !> its version, which is what lets the server diagnose an old client + !> misbehaving. + character(len=:), allocatable :: user_agent + !> Seconds to wait **per socket operation**: it caps the connect phase + !> and aborts a transfer that stalls for that long. It is not a cap on + !> the whole call — that is `total_timeout`. + real(real64) :: timeout = 10.0_real64 + !> How many attempts in total, counting the first. `1` disables + !> retrying. The default of `3` covers the common case (one transient + !> failure) without turning a real outage into a long wait. + integer :: max_attempts = 3 + !> Base of the exponential wait, in seconds. The actual wait is drawn + !> from `[0, base * 2**(n-1)]` — *full jitter*. The randomness is not + !> decoration: without it, N clients that fail together come back + !> together and reproduce the spike that took the service down. + real(real64) :: backoff_base = 0.5_real64 + !> Cap on each individual wait, in seconds. It applies to a + !> server-sent `Retry-After` too, or a `Retry-After: 3600` from a + !> misconfigured proxy would park the caller for an hour. + real(real64) :: backoff_max = 8.0_real64 + !> Cap on the whole call, attempts and waits included. `0` leaves + !> `max_attempts` as the only bound. Set it in code serving a web + !> request: without it the worst case is `max_attempts * timeout` plus + !> the sum of the backoffs. + real(real64) :: total_timeout = 0.0_real64 + contains + !> Look up a single CEP. + procedure :: lookup => client_lookup + !> Look up many CEPs in one batch. + procedure :: lookup_many => client_lookup_many + !> Query `GET /health`. + procedure :: health => client_health + !> The base URL in use, trailing slash stripped. + procedure :: url => client_url + !> The `User-Agent` in use. + procedure :: agent => client_agent + end type cepis_client + + type(cepis_client), save :: default_client + logical, save :: seeded = .false. + +contains + + !> Build a client, validating every value. + !> + !> Omitted arguments keep their defaults: `https://cep.is`, 10 s per socket + !> operation, 3 attempts, 0.5 s backoff base, 8 s backoff cap, no total + !> timeout. + subroutine cepis_client_init(client, status, message, base_url, user_agent, & + timeout, max_attempts, backoff_base, & + backoff_max, total_timeout) + type(cepis_client), intent(out) :: client + integer, intent(out) :: status + character(len=:), allocatable, intent(out) :: message + character(len=*), intent(in), optional :: base_url + character(len=*), intent(in), optional :: user_agent + real(real64), intent(in), optional :: timeout + integer, intent(in), optional :: max_attempts + real(real64), intent(in), optional :: backoff_base + real(real64), intent(in), optional :: backoff_max + real(real64), intent(in), optional :: total_timeout + character(len=:), allocatable :: trimmed + integer :: last + + status = CEPIS_OK + message = '' + + client%base_url = CEPIS_DEFAULT_BASE_URL + client%user_agent = 'cepis-fortran/'//CEPIS_VERSION//' (+https://cep.is)' + + if (present(base_url)) then + trimmed = strip(base_url) + last = len(trimmed) + do while (last > 0) + if (trimmed(last:last) /= '/') exit + last = last - 1 + end do + if (last <= 0) then + status = CEPIS_ERR_CONFIG + message = 'base_url must not be empty' + return + end if + client%base_url = trimmed(1:last) + end if + + if (present(user_agent)) then + if (len(strip(user_agent)) == 0) then + status = CEPIS_ERR_CONFIG + message = 'user_agent must not be empty' + return + end if + client%user_agent = strip(user_agent) + end if + + if (present(timeout)) then + if (timeout <= 0.0_real64) then + status = CEPIS_ERR_CONFIG + message = 'timeout must be > 0' + return + end if + client%timeout = timeout + end if + + if (present(max_attempts)) then + if (max_attempts < 1) then + status = CEPIS_ERR_CONFIG + message = 'max_attempts must be >= 1' + return + end if + client%max_attempts = max_attempts + end if + + if (present(backoff_base)) then + if (backoff_base < 0.0_real64) then + status = CEPIS_ERR_CONFIG + message = 'backoff_base must be >= 0' + return + end if + client%backoff_base = backoff_base + end if + + if (present(backoff_max)) then + if (backoff_max < 0.0_real64) then + status = CEPIS_ERR_CONFIG + message = 'backoff_max must be >= 0' + return + end if + client%backoff_max = backoff_max + end if + + if (present(total_timeout)) then + if (total_timeout < 0.0_real64) then + status = CEPIS_ERR_CONFIG + message = 'total_timeout must be >= 0' + return + end if + client%total_timeout = total_timeout + end if + end subroutine cepis_client_init + + pure function client_url(self) result(text) + class(cepis_client), intent(in) :: self + character(len=:), allocatable :: text + + if (allocated(self%base_url)) then + text = self%base_url + else + text = CEPIS_DEFAULT_BASE_URL + end if + end function client_url + + pure function client_agent(self) result(text) + class(cepis_client), intent(in) :: self + character(len=:), allocatable :: text + + if (allocated(self%user_agent)) then + text = self%user_agent + else + text = 'cepis-fortran/'//CEPIS_VERSION//' (+https://cep.is)' + end if + end function client_agent + + !> Return the CEP's 8 digits, accepting the mask. + !> + !> `01001-000`, `01001000` and ` 01001-000 ` all become `01001000`. + !> + !> The client runs this **before** any request: a 7-digit CEP is the + !> caller's bug, and spending a round trip for the server to say so wastes + !> both sides' time. + subroutine cepis_normalize_cep(value, digits, status, message) + character(len=*), intent(in) :: value + character(len=:), allocatable, intent(out) :: digits + integer, intent(out) :: status + character(len=:), allocatable, intent(out) :: message + integer :: i + + digits = '' + do i = 1, len(value) + select case (value(i:i)) + case ('0':'9') + digits = digits//value(i:i) + case (' ', '-', '.', char(9)) + cycle + case default + status = CEPIS_ERR_INVALID_CEP + message = 'CEP must be 8 digits, got '''//strip(value)//'''' + digits = '' + return + end select + end do + + if (len(digits) /= 8) then + status = CEPIS_ERR_INVALID_CEP + message = 'CEP must be 8 digits, got '''//strip(value)//'''' + digits = '' + return + end if + + status = CEPIS_OK + message = '' + end subroutine cepis_normalize_cep + + !> Look up a single CEP. + !> + !> A 400 from the API is surfaced as `CEPIS_ERR_INVALID_CEP` carrying the + !> API's own message: the format already passed local validation, so the + !> server knows something this client does not. + !> + !> This is the only call that carries `has_geo` and `geo`. + subroutine client_lookup(self, cep, address, status, message, http_status, retry_after) + class(cepis_client), intent(in) :: self + character(len=*), intent(in) :: cep + type(cepis_address), intent(out) :: address + integer, intent(out) :: status + character(len=:), allocatable, intent(out) :: message + integer, intent(out), optional :: http_status + real(real64), intent(out), optional :: retry_after + character(len=:), allocatable :: digits + type(http_response) :: response + type(json_document) :: doc + logical :: ok + + call address_clear(address) + if (present(http_status)) http_status = 0 + if (present(retry_after)) retry_after = -1.0_real64 + + call cepis_normalize_cep(cep, digits, status, message) + if (status /= CEPIS_OK) return + + call request(self, '/'//digits, .false., response, status, message, & + http_status, retry_after) + if (status /= CEPIS_OK) return + + if (present(http_status)) http_status = response%status + + if (response%status == 404) then + status = CEPIS_ERR_NOT_FOUND + message = 'CEP '//digits//' does not exist in the DNE database' + return + end if + + if (response%status == 400) then + status = CEPIS_ERR_INVALID_CEP + message = api_message(response%body, 'CEP '//digits//' rejected') + return + end if + + call read_object(response%body, doc, ok, message) + if (.not. ok) then + status = CEPIS_ERR_INVALID_RESPONSE + return + end if + + call address_from_json(doc, doc%root, response%body, address) + status = CEPIS_OK + message = '' + end subroutine client_lookup + + !> Look up many CEPs in one batch. + !> + !> `addresses` has **the same length and the same order** as `ceps`. A CEP + !> that does not exist comes back with `found = .false.` at its position — + !> it does not vanish from the array, and it is not an error. That is the + !> right difference from `lookup`: in a batch of a thousand, one bad CEP + !> must not cost the other nine hundred and ninety-nine. A malformed CEP is + !> `found = .false.` for the same reason; call `cepis_normalize_cep` first + !> if you need to know which one it was. + !> + !> Trailing blanks in each element are ignored, so a literal array such as + !> `['01001000', '99999999']` works as written. + !> + !> Input is chunked into blocks of `CEPIS_MAX_BATCH` automatically. Do not + !> loop over `lookup` instead: a loop of 500 calls pays 500 round trips, + !> this pays one. + !> + !> **The batch carries no coordinate.** The endpoint behind it is CSV, and + !> the CSV has no `geo` column. Every address returned here has + !> `has_geo = .false.`, including for CEPs that do have one. Need `geo`? + !> Use `lookup`, one at a time. + subroutine client_lookup_many(self, ceps, addresses, status, message, & + http_status, retry_after) + class(cepis_client), intent(in) :: self + character(len=*), intent(in) :: ceps(:) + type(cepis_address), allocatable, intent(out) :: addresses(:) + integer, intent(out) :: status + character(len=:), allocatable, intent(out) :: message + integer, intent(out), optional :: http_status + real(real64), intent(out), optional :: retry_after + integer :: total, first, last, i + + status = CEPIS_OK + message = '' + if (present(http_status)) http_status = 0 + if (present(retry_after)) retry_after = -1.0_real64 + + total = size(ceps) + allocate (addresses(total)) + do i = 1, total + call address_clear(addresses(i)) + addresses(i)%cep = strip(ceps(i)) + end do + if (total == 0) return + + first = 1 + do while (first <= total) + last = min(first + CEPIS_MAX_BATCH - 1, total) + call lookup_chunk(self, ceps, first, last, addresses, status, & + message, http_status, retry_after) + if (status /= CEPIS_OK) return + first = last + 1 + end do + end subroutine client_lookup_many + + !> Query `GET /health`: does the API answer, and with which database. + !> + !> Does not fail for an API reporting itself degraded — that arrives in + !> `health%status`, and checking health is exactly when you want the + !> diagnosis rather than an error. Network failures still fail. + subroutine client_health(self, health, status, message, http_status, retry_after) + class(cepis_client), intent(in) :: self + type(cepis_health), intent(out) :: health + integer, intent(out) :: status + character(len=:), allocatable, intent(out) :: message + integer, intent(out), optional :: http_status + real(real64), intent(out), optional :: retry_after + type(http_response) :: response + type(json_document) :: doc + logical :: ok + + health%status = '' + health%dne = '' + health%base_gerada_em = '' + if (present(http_status)) http_status = 0 + if (present(retry_after)) retry_after = -1.0_real64 + + call request(self, '/health', .true., response, status, message, & + http_status, retry_after) + if (status /= CEPIS_OK) return + + if (present(http_status)) http_status = response%status + + call read_object(response%body, doc, ok, message) + if (.not. ok) then + status = CEPIS_ERR_INVALID_RESPONSE + return + end if + + call health_from_json(doc, doc%root, health) + status = CEPIS_OK + message = '' + end subroutine client_health + + subroutine lookup_chunk(self, ceps, first, last, addresses, status, & + message, http_status, retry_after) + class(cepis_client), intent(in) :: self + character(len=*), intent(in) :: ceps(:) + integer, intent(in) :: first + integer, intent(in) :: last + type(cepis_address), intent(inout) :: addresses(:) + integer, intent(out) :: status + character(len=:), allocatable, intent(out) :: message + integer, intent(out), optional :: http_status + real(real64), intent(out), optional :: retry_after + type(http_response) :: response + type(csv_table) :: table + character(len=:), allocatable :: query + logical :: ok + integer :: i, row + + query = '' + do i = first, last + if (i > first) query = query//'%2C' + query = query//url_encode(strip(ceps(i))) + end do + + call request(self, '/csv?ceps='//query, .false., response, status, & + message, http_status, retry_after) + if (status /= CEPIS_OK) return + + if (present(http_status)) http_status = response%status + + call csv_parse(response%body, table, ok, message) + if (ok) ok = table%height() >= 1 + if (ok) ok = table%column('cep') > 0 + if (.not. ok) then + status = CEPIS_ERR_INVALID_RESPONSE + if (len(message) == 0) message = 'the batch response is not the expected CSV' + return + end if + + do i = first, last + row = 1 + (i - first) + 1 + if (row > table%height()) exit + if (len(strip(table%cell(row, 'localidade'))) == 0) cycle + call address_from_row(table, row, addresses(i)) + end do + + status = CEPIS_OK + message = '' + end subroutine lookup_chunk + + subroutine address_from_row(table, row, address) + type(csv_table), intent(in) :: table + integer, intent(in) :: row + type(cepis_address), intent(inout) :: address + + address%found = .true. + address%cep = table%cell(row, 'cep') + address%logradouro = table%cell(row, 'logradouro') + address%complemento = table%cell(row, 'complemento') + address%unidade = table%cell(row, 'unidade') + address%bairro = table%cell(row, 'bairro') + address%localidade = table%cell(row, 'localidade') + address%uf = table%cell(row, 'uf') + address%estado = table%cell(row, 'estado') + address%regiao = table%cell(row, 'regiao') + address%ibge = table%cell(row, 'ibge') + address%gia = table%cell(row, 'gia') + address%ddd = table%cell(row, 'ddd') + address%siafi = table%cell(row, 'siafi') + address%has_geo = .false. + address%raw = '' + end subroutine address_from_row + + subroutine request(self, path, accept_unavailable, response, status, & + message, http_status, retry_after) + class(cepis_client), intent(in) :: self + character(len=*), intent(in) :: path + logical, intent(in) :: accept_unavailable + type(http_response), intent(out) :: response + integer, intent(out) :: status + character(len=:), allocatable, intent(out) :: message + integer, intent(out), optional :: http_status + real(real64), intent(out), optional :: retry_after + character(len=:), allocatable :: url, detail + real(real64) :: deadline, wait, remaining, last_retry_after + integer :: attempt, last_status + logical :: ok + + url = self%url()//path + status = CEPIS_OK + message = '' + last_status = 0 + last_retry_after = -1.0_real64 + detail = '' + + deadline = -1.0_real64 + if (self%total_timeout > 0.0_real64) deadline = http_monotonic() + self%total_timeout + + do attempt = 1, self%max_attempts + if (deadline > 0.0_real64) then + if (http_monotonic() >= deadline) exit + end if + + call http_get(url, self%agent(), ACCEPT_HEADER, self%timeout, & + response, ok, detail) + + if (ok) then + if (response%status == 200) return + if (accept_unavailable .and. response%status == 503) return + if (.not. retriable(response%status)) return + last_status = response%status + last_retry_after = response%retry_after + detail = '' + else + last_status = 0 + last_retry_after = -1.0_real64 + end if + + if (attempt == self%max_attempts) exit + + wait = backoff(self, attempt, last_retry_after) + if (deadline > 0.0_real64) then + remaining = deadline - http_monotonic() + if (remaining <= 0.0_real64) exit + wait = min(wait, remaining) + end if + call http_sleep(wait) + end do + + if (present(http_status)) http_status = last_status + if (present(retry_after)) retry_after = last_retry_after + + if (last_status == 429) then + status = CEPIS_ERR_RATE_LIMITED + message = 'rate limit reached at '//url//' (after '// & + from_integer(int(self%max_attempts, int64))//' attempt(s))' + else if (last_status /= 0) then + status = CEPIS_ERR_SERVER + message = 'the API answered '//from_integer(int(last_status, int64))// & + ' at '//url//' (after '// & + from_integer(int(self%max_attempts, int64))//' attempt(s))' + else + status = CEPIS_ERR_NETWORK + message = 'could not reach '//url//' (after '// & + from_integer(int(self%max_attempts, int64))//' attempt(s)): '//detail + end if + end subroutine request + + pure function retriable(http_status) result(yes) + integer, intent(in) :: http_status + logical :: yes + + select case (http_status) + case (429, 500, 502, 503, 504) + yes = .true. + case default + yes = .false. + end select + end function retriable + + function backoff(self, attempt, retry_after) result(wait) + class(cepis_client), intent(in) :: self + integer, intent(in) :: attempt + real(real64), intent(in) :: retry_after + real(real64) :: wait, ceiling_value, draw + + if (retry_after >= 0.0_real64) then + wait = min(retry_after, self%backoff_max) + return + end if + + if (.not. seeded) then + call random_init(.false., .false.) + seeded = .true. + end if + + ceiling_value = min(self%backoff_base*2.0_real64**(attempt - 1), self%backoff_max) + call random_number(draw) + wait = draw*ceiling_value + end function backoff + + subroutine read_object(body, doc, ok, message) + character(len=*), intent(in) :: body + type(json_document), intent(out) :: doc + logical, intent(out) :: ok + character(len=:), allocatable, intent(out) :: message + character(len=:), allocatable :: detail + integer :: shown + + call json_parse(body, doc, ok, detail) + if (.not. ok) then + shown = min(len(body), 120) + message = 'response is not valid JSON — something between you and '// & + 'the API is answering instead of it: '''//body(1:shown)// & + ''' ('//detail//')' + return + end if + + if (doc%kind_of(doc%root) /= JSON_OBJECT) then + ok = .false. + message = 'expected a JSON object at the top level' + return + end if + + message = '' + end subroutine read_object + + function api_message(body, fallback) result(text) + character(len=*), intent(in) :: body + character(len=*), intent(in) :: fallback + character(len=:), allocatable :: text + type(json_document) :: doc + character(len=:), allocatable :: detail + logical :: ok + + text = fallback + call json_parse(body, doc, ok, detail) + if (.not. ok) return + if (doc%kind_of(doc%root) /= JSON_OBJECT) return + detail = doc%field_text(doc%root, 'mensagem') + if (len(detail) > 0) text = detail + end function api_message + + subroutine ensure_default() + if (.not. allocated(default_client%base_url)) then + default_client%base_url = CEPIS_DEFAULT_BASE_URL + default_client%user_agent = 'cepis-fortran/'//CEPIS_VERSION//' (+https://cep.is)' + end if + end subroutine ensure_default + + !> `lookup` on a shared default client pointed at `https://cep.is`. + subroutine cepis_lookup(cep, address, status, message) + character(len=*), intent(in) :: cep + type(cepis_address), intent(out) :: address + integer, intent(out) :: status + character(len=:), allocatable, intent(out) :: message + + call ensure_default() + call default_client%lookup(cep, address, status, message) + end subroutine cepis_lookup + + !> `lookup_many` on a shared default client pointed at `https://cep.is`. + subroutine cepis_lookup_many(ceps, addresses, status, message) + character(len=*), intent(in) :: ceps(:) + type(cepis_address), allocatable, intent(out) :: addresses(:) + integer, intent(out) :: status + character(len=:), allocatable, intent(out) :: message + + call ensure_default() + call default_client%lookup_many(ceps, addresses, status, message) + end subroutine cepis_lookup_many + + !> `health` on a shared default client pointed at `https://cep.is`. + subroutine cepis_check_health(health, status, message) + type(cepis_health), intent(out) :: health + integer, intent(out) :: status + character(len=:), allocatable, intent(out) :: message + + call ensure_default() + call default_client%health(health, status, message) + end subroutine cepis_check_health + +end module cepis diff --git a/src/cepis_csv.f90 b/src/cepis_csv.f90 new file mode 100644 index 0000000..80502c6 --- /dev/null +++ b/src/cepis_csv.f90 @@ -0,0 +1,218 @@ +!> A small RFC 4180 CSV reader. +!> +!> Fortran ships no CSV parser and the batch endpoint needs a real one: a value +!> such as `Rua Um, Dois` arrives double-quoted with `""` escaping, and +!> splitting on commas would silently shift every column after it. +!> +!> Accepts LF and CRLF line endings, a leading UTF-8 byte-order mark, and +!> quoted fields containing commas, quotes and newlines. +module cepis_csv + use cepis_strings, only: string_buffer + implicit none + private + + !> One field of one row. + type, public :: csv_field + character(len=:), allocatable :: text + end type csv_field + + !> One row of fields. + type, public :: csv_row + type(csv_field), allocatable :: fields(:) + end type csv_row + + !> A parsed table. `rows(1)` is the header row when the file has one. + type, public :: csv_table + type(csv_row), allocatable :: rows(:) + contains + !> How many rows, header included. Zero for an empty document. + procedure :: height + !> Index of the header column named `name`, or zero when absent. + procedure :: column + !> The value at `row`, column `name`. The empty string when either the + !> row or the column is missing. + procedure :: cell + end type csv_table + + public :: csv_parse + +contains + + pure function height(self) result(n) + class(csv_table), intent(in) :: self + integer :: n + + n = 0 + if (allocated(self%rows)) n = size(self%rows) + end function height + + pure function column(self, name) result(index) + class(csv_table), intent(in) :: self + character(len=*), intent(in) :: name + integer :: index, i + + index = 0 + if (self%height() < 1) return + if (.not. allocated(self%rows(1)%fields)) return + do i = 1, size(self%rows(1)%fields) + if (self%rows(1)%fields(i)%text == name) then + index = i + return + end if + end do + end function column + + pure function cell(self, row, name) result(text) + class(csv_table), intent(in) :: self + integer, intent(in) :: row + character(len=*), intent(in) :: name + character(len=:), allocatable :: text + integer :: col + + text = '' + if (row < 1 .or. row > self%height()) return + col = self%column(name) + if (col == 0) return + if (.not. allocated(self%rows(row)%fields)) return + if (col > size(self%rows(row)%fields)) return + text = self%rows(row)%fields(col)%text + end function cell + + !> Parse `text` into a table. `ok` is `.false.` only for an unterminated + !> quoted field, the one malformation that cannot be read past safely. + subroutine csv_parse(text, table, ok, message) + character(len=*), intent(in) :: text + type(csv_table), intent(out) :: table + logical, intent(out) :: ok + character(len=:), allocatable, intent(out) :: message + type(csv_row), allocatable :: rows(:), bigger(:) + type(csv_row) :: current + integer :: pos, count + + ok = .true. + message = '' + allocate (rows(16)) + count = 0 + + pos = 1 + if (len(text) >= 3) then + if (iachar(text(1:1)) == 239 .and. iachar(text(2:2)) == 187 .and. & + iachar(text(3:3)) == 191) pos = 4 + end if + + do while (pos <= len(text)) + call parse_row(text, pos, current, ok, message) + if (.not. ok) return + if (count >= size(rows)) then + allocate (bigger(2*size(rows))) + bigger(1:count) = rows(1:count) + call move_alloc(bigger, rows) + end if + count = count + 1 + rows(count) = current + end do + + allocate (table%rows(count)) + if (count > 0) table%rows = rows(1:count) + end subroutine csv_parse + + subroutine parse_row(text, pos, row, ok, message) + character(len=*), intent(in) :: text + integer, intent(inout) :: pos + type(csv_row), intent(out) :: row + logical, intent(out) :: ok + character(len=:), allocatable, intent(out) :: message + type(csv_field), allocatable :: fields(:), bigger(:) + character(len=:), allocatable :: value + integer :: count + + ok = .true. + message = '' + allocate (fields(16)) + count = 0 + + do + call parse_field(text, pos, value, ok, message) + if (.not. ok) return + if (count >= size(fields)) then + allocate (bigger(2*size(fields))) + bigger(1:count) = fields(1:count) + call move_alloc(bigger, fields) + end if + count = count + 1 + fields(count)%text = value + + if (pos > len(text)) exit + if (text(pos:pos) == ',') then + pos = pos + 1 + cycle + end if + if (text(pos:pos) == char(13)) pos = pos + 1 + if (pos <= len(text)) then + if (text(pos:pos) == char(10)) pos = pos + 1 + end if + exit + end do + + allocate (row%fields(count)) + row%fields = fields(1:count) + end subroutine parse_row + + subroutine parse_field(text, pos, value, ok, message) + character(len=*), intent(in) :: text + integer, intent(inout) :: pos + character(len=:), allocatable, intent(out) :: value + logical, intent(out) :: ok + character(len=:), allocatable, intent(out) :: message + type(string_buffer) :: out + integer :: first + + ok = .true. + message = '' + value = '' + + if (pos > len(text)) return + + if (text(pos:pos) /= '"') then + first = pos + do while (pos <= len(text)) + if (text(pos:pos) == ',' .or. text(pos:pos) == char(10) .or. & + text(pos:pos) == char(13)) exit + pos = pos + 1 + end do + if (pos > first) value = text(first:pos - 1) + return + end if + + pos = pos + 1 + do + if (pos > len(text)) then + ok = .false. + message = 'unterminated quoted field' + return + end if + if (text(pos:pos) == '"') then + if (pos + 1 <= len(text)) then + if (text(pos + 1:pos + 1) == '"') then + call out%append('"') + pos = pos + 2 + cycle + end if + end if + pos = pos + 1 + exit + end if + call out%append(text(pos:pos)) + pos = pos + 1 + end do + + value = out%text() + + do while (pos <= len(text)) + if (text(pos:pos) == ',' .or. text(pos:pos) == char(10) .or. & + text(pos:pos) == char(13)) exit + pos = pos + 1 + end do + end subroutine parse_field + +end module cepis_csv diff --git a/src/cepis_errors.f90 b/src/cepis_errors.f90 new file mode 100644 index 0000000..5a86dec --- /dev/null +++ b/src/cepis_errors.f90 @@ -0,0 +1,83 @@ +!> Status codes returned by every fallible procedure in this library. +!> +!> Fortran has no exceptions, so every call that can fail takes an +!> `integer, intent(out) :: status` and a +!> `character(len=:), allocatable, intent(out) :: message`. `status` is one of +!> the parameters below; `message` is always allocated, and is the empty string +!> on success. +!> +!> The split is by **the decision the caller has to make**, not by the HTTP +!> status that caused it. `CEPIS_ERR_INVALID_CEP` and `CEPIS_ERR_NOT_FOUND` are +!> problems with the request: retrying returns the same answer more slowly. The +!> three transport errors below them may succeed later, and the client already +!> retried on its own before returning any of them. +module cepis_errors + implicit none + private + + !> The call succeeded. + integer, parameter, public :: CEPIS_OK = 0 + + !> The CEP is not 8 digits, or the API rejected it with a 400. + !> + !> Usually returned without any request being made: the client validates + !> the format before going to the network. + integer, parameter, public :: CEPIS_ERR_INVALID_CEP = 1 + + !> The CEP is well-formed but does not exist in the DNE database. + integer, parameter, public :: CEPIS_ERR_NOT_FOUND = 2 + + !> The API answered 429 on every attempt. `retry_after` carries what the + !> server asked for, in seconds, or a negative value when it did not say. + integer, parameter, public :: CEPIS_ERR_RATE_LIMITED = 3 + + !> The API answered 5xx on every attempt. `http_status` carries the status + !> seen on the last attempt. + integer, parameter, public :: CEPIS_ERR_SERVER = 4 + + !> The request never completed: DNS, refused connection, timeout, TLS. + integer, parameter, public :: CEPIS_ERR_NETWORK = 5 + + !> A success status came back with a body that cannot be parsed. + !> + !> In practice something between the caller and the API is answering + !> instead of it: a captive Wi-Fi portal, a corporate proxy, an HTML error + !> page. + integer, parameter, public :: CEPIS_ERR_INVALID_RESPONSE = 6 + + !> A configuration value is out of range. Not one of the six categories + !> above: it is a programming error, caught before any request is made. + integer, parameter, public :: CEPIS_ERR_CONFIG = 7 + + public :: cepis_status_name + +contains + + !> A short, stable, English name for a status code. + pure function cepis_status_name(status) result(name) + integer, intent(in) :: status + character(len=:), allocatable :: name + + select case (status) + case (CEPIS_OK) + name = 'ok' + case (CEPIS_ERR_INVALID_CEP) + name = 'invalid_cep' + case (CEPIS_ERR_NOT_FOUND) + name = 'not_found' + case (CEPIS_ERR_RATE_LIMITED) + name = 'rate_limited' + case (CEPIS_ERR_SERVER) + name = 'server_error' + case (CEPIS_ERR_NETWORK) + name = 'network_error' + case (CEPIS_ERR_INVALID_RESPONSE) + name = 'invalid_response' + case (CEPIS_ERR_CONFIG) + name = 'config_error' + case default + name = 'unknown' + end select + end function cepis_status_name + +end module cepis_errors diff --git a/src/cepis_http.f90 b/src/cepis_http.f90 new file mode 100644 index 0000000..2c178a1 --- /dev/null +++ b/src/cepis_http.f90 @@ -0,0 +1,477 @@ +!> The transport, bound to libcurl through `iso_c_binding`. +!> +!> Fortran has neither an HTTP client nor sockets, so the only honest answer is +!> a foreign-function binding. The interface bodies below are written by hand +!> against the documented libcurl ABI; nothing is vendored. +!> +!> `curl_easy_setopt` and `curl_easy_getinfo` are variadic in C. They are bound +!> here with a single pointer-sized third argument and integers are passed +!> through `transfer`, which is what the SysV and AAPCS64 calling conventions +!> ask for. This is the reason the library is built and tested on the platform +!> it runs on rather than assumed to be portable to every ABI. +!> +!> One attempt per call: retrying, backoff and `Retry-After` policy live in the +!> client, because they are decisions about the API and not about the socket. +module cepis_http + use, intrinsic :: iso_c_binding + use, intrinsic :: iso_fortran_env, only: real64, int64 + use cepis_strings, only: string_buffer, to_c_chars, from_c_string, strip, & + lower, starts_with, is_digits, parse_real + implicit none + private + + public :: http_response + public :: http_get + public :: http_sleep + public :: http_monotonic + public :: http_parse_retry_after + + integer(c_int), parameter :: CURLOPT_WRITEDATA = 10001 + integer(c_int), parameter :: CURLOPT_URL = 10002 + integer(c_int), parameter :: CURLOPT_ERRORBUFFER = 10010 + integer(c_int), parameter :: CURLOPT_WRITEFUNCTION = 20011 + integer(c_int), parameter :: CURLOPT_LOW_SPEED_LIMIT = 19 + integer(c_int), parameter :: CURLOPT_LOW_SPEED_TIME = 20 + integer(c_int), parameter :: CURLOPT_HTTPHEADER = 10023 + integer(c_int), parameter :: CURLOPT_USERAGENT = 10018 + integer(c_int), parameter :: CURLOPT_FOLLOWLOCATION = 52 + integer(c_int), parameter :: CURLOPT_MAXREDIRS = 68 + integer(c_int), parameter :: CURLOPT_HTTPGET = 80 + integer(c_int), parameter :: CURLOPT_NOSIGNAL = 99 + integer(c_int), parameter :: CURLOPT_ACCEPT_ENCODING = 10102 + integer(c_int), parameter :: CURLOPT_TIMEOUT_MS = 155 + integer(c_int), parameter :: CURLOPT_CONNECTTIMEOUT_MS = 156 + integer(c_int), parameter :: CURLOPT_HEADERFUNCTION = 20079 + integer(c_int), parameter :: CURLOPT_HEADERDATA = 10029 + + integer(c_int), parameter :: CURLINFO_RESPONSE_CODE = 2097154 + integer(c_long), parameter :: CURL_GLOBAL_ALL = 3_c_long + integer, parameter :: CURL_ERROR_SIZE = 256 + + !> What one HTTP attempt produced. + type :: http_response + !> The HTTP status, or zero when the request never completed. + integer :: status = 0 + !> The body, always allocated. + character(len=:), allocatable :: body + !> Seconds the server asked the caller to wait, when it sent + !> `Retry-After`. Negative when it did not. + real(real64) :: retry_after = -1.0_real64 + end type http_response + + !> Where the header callback accumulates what it understood. + type :: header_state + real(real64) :: retry_after = -1.0_real64 + end type header_state + + logical, save :: global_ready = .false. + + type, bind(c) :: c_timespec + integer(c_long) :: tv_sec + integer(c_long) :: tv_nsec + end type c_timespec + + interface + function curl_global_init(flags) bind(c, name='curl_global_init') result(rc) + import :: c_int, c_long + integer(c_long), value :: flags + integer(c_int) :: rc + end function curl_global_init + + function curl_easy_init() bind(c, name='curl_easy_init') result(handle) + import :: c_ptr + type(c_ptr) :: handle + end function curl_easy_init + + subroutine curl_easy_cleanup(handle) bind(c, name='curl_easy_cleanup') + import :: c_ptr + type(c_ptr), value :: handle + end subroutine curl_easy_cleanup + + function curl_easy_setopt(handle, option, argument) & + bind(c, name='curl_easy_setopt') result(rc) + import :: c_ptr, c_int + type(c_ptr), value :: handle + integer(c_int), value :: option + type(c_ptr), value :: argument + integer(c_int) :: rc + end function curl_easy_setopt + + function curl_easy_getinfo(handle, info, argument) & + bind(c, name='curl_easy_getinfo') result(rc) + import :: c_ptr, c_int + type(c_ptr), value :: handle + integer(c_int), value :: info + type(c_ptr), value :: argument + integer(c_int) :: rc + end function curl_easy_getinfo + + function curl_easy_perform(handle) bind(c, name='curl_easy_perform') result(rc) + import :: c_ptr, c_int + type(c_ptr), value :: handle + integer(c_int) :: rc + end function curl_easy_perform + + function curl_easy_strerror(rc) bind(c, name='curl_easy_strerror') result(text) + import :: c_ptr, c_int + integer(c_int), value :: rc + type(c_ptr) :: text + end function curl_easy_strerror + + function curl_slist_append(list, text) bind(c, name='curl_slist_append') result(out) + import :: c_ptr, c_char + type(c_ptr), value :: list + character(kind=c_char), intent(in) :: text(*) + type(c_ptr) :: out + end function curl_slist_append + + subroutine curl_slist_free_all(list) bind(c, name='curl_slist_free_all') + import :: c_ptr + type(c_ptr), value :: list + end subroutine curl_slist_free_all + + function c_time(destination) bind(c, name='time') result(seconds) + import :: c_ptr, c_long + type(c_ptr), value :: destination + integer(c_long) :: seconds + end function c_time + + function c_nanosleep(request, remaining) bind(c, name='nanosleep') result(rc) + import :: c_ptr, c_int, c_timespec + type(c_timespec), intent(in) :: request + type(c_ptr), value :: remaining + integer(c_int) :: rc + end function c_nanosleep + end interface + +contains + + !> Perform one `GET`. + !> + !> `ok` is `.false.` only when the request never completed — a DNS failure, + !> a refused connection, a timeout, a TLS error. Every HTTP status, + !> including 5xx, is a completed request and comes back in + !> `response%status`. + !> + !> `timeout` bounds each socket operation: it caps the connect phase and + !> aborts a transfer that stalls for that long. It is not a cap on the whole + !> call. + subroutine http_get(url, user_agent, accept, timeout, response, ok, message) + character(len=*), intent(in) :: url + character(len=*), intent(in) :: user_agent + character(len=*), intent(in) :: accept + real(real64), intent(in) :: timeout + type(http_response), intent(out) :: response + logical, intent(out) :: ok + character(len=:), allocatable, intent(out) :: message + + type(c_ptr) :: handle, headers + type(string_buffer), target :: body + type(header_state), target :: header + character(kind=c_char), allocatable, target :: c_url(:), c_agent(:), & + c_accept(:), c_identity(:) + character(kind=c_char), target :: error_buffer(CURL_ERROR_SIZE) + integer(c_long), target :: status_code + integer(c_int) :: rc + integer(c_long) :: milliseconds, stall_seconds + + response%body = '' + ok = .false. + message = '' + + if (.not. global_ready) then + rc = curl_global_init(CURL_GLOBAL_ALL) + if (rc /= 0) then + message = 'could not initialise libcurl' + return + end if + global_ready = .true. + end if + + handle = curl_easy_init() + if (.not. c_associated(handle)) then + message = 'could not create a libcurl handle' + return + end if + + error_buffer = c_null_char + + c_url = to_c_chars(url) + c_agent = to_c_chars(user_agent) + c_accept = to_c_chars('Accept: '//accept) + c_identity = to_c_chars('identity') + + headers = curl_slist_append(c_null_ptr, c_accept) + + milliseconds = max(1_c_long, int(timeout*1000.0_real64, c_long)) + stall_seconds = max(1_c_long, int(ceiling(timeout), c_long)) + + rc = set_pointer(handle, CURLOPT_URL, c_loc(c_url(1))) + rc = set_long(handle, CURLOPT_HTTPGET, 1_c_long) + rc = set_long(handle, CURLOPT_NOSIGNAL, 1_c_long) + rc = set_long(handle, CURLOPT_FOLLOWLOCATION, 1_c_long) + rc = set_long(handle, CURLOPT_MAXREDIRS, 5_c_long) + rc = set_pointer(handle, CURLOPT_USERAGENT, c_loc(c_agent(1))) + rc = set_pointer(handle, CURLOPT_ACCEPT_ENCODING, c_loc(c_identity(1))) + rc = set_pointer(handle, CURLOPT_HTTPHEADER, headers) + rc = set_long(handle, CURLOPT_CONNECTTIMEOUT_MS, milliseconds) + rc = set_long(handle, CURLOPT_LOW_SPEED_LIMIT, 1_c_long) + rc = set_long(handle, CURLOPT_LOW_SPEED_TIME, stall_seconds) + rc = set_function(handle, CURLOPT_WRITEFUNCTION, c_funloc(write_body)) + rc = set_pointer(handle, CURLOPT_WRITEDATA, c_loc(body)) + rc = set_function(handle, CURLOPT_HEADERFUNCTION, c_funloc(read_header)) + rc = set_pointer(handle, CURLOPT_HEADERDATA, c_loc(header)) + rc = set_pointer(handle, CURLOPT_ERRORBUFFER, c_loc(error_buffer(1))) + + rc = curl_easy_perform(handle) + + if (rc /= 0) then + message = detail(error_buffer, rc) + call curl_slist_free_all(headers) + call curl_easy_cleanup(handle) + return + end if + + status_code = 0_c_long + rc = curl_easy_getinfo(handle, CURLINFO_RESPONSE_CODE, c_loc(status_code)) + + response%status = int(status_code) + response%body = body%text() + response%retry_after = header%retry_after + ok = .true. + + call curl_slist_free_all(headers) + call curl_easy_cleanup(handle) + end subroutine http_get + + function detail(error_buffer, rc) result(text) + character(kind=c_char), intent(in) :: error_buffer(CURL_ERROR_SIZE) + integer(c_int), intent(in) :: rc + character(len=:), allocatable :: text + integer :: i + + text = '' + do i = 1, CURL_ERROR_SIZE + if (error_buffer(i) == c_null_char) exit + text = text//error_buffer(i) + end do + if (len(text) == 0) text = from_c_string(curl_easy_strerror(rc)) + if (len(text) == 0) text = 'libcurl error' + end function detail + + function set_long(handle, option, value) result(rc) + type(c_ptr), intent(in) :: handle + integer(c_int), intent(in) :: option + integer(c_long), intent(in) :: value + integer(c_int) :: rc + + rc = curl_easy_setopt(handle, option, transfer(int(value, c_intptr_t), c_null_ptr)) + end function set_long + + function set_pointer(handle, option, value) result(rc) + type(c_ptr), intent(in) :: handle + integer(c_int), intent(in) :: option + type(c_ptr), intent(in) :: value + integer(c_int) :: rc + + rc = curl_easy_setopt(handle, option, value) + end function set_pointer + + function set_function(handle, option, value) result(rc) + type(c_ptr), intent(in) :: handle + integer(c_int), intent(in) :: option + type(c_funptr), intent(in) :: value + integer(c_int) :: rc + + rc = curl_easy_setopt(handle, option, transfer(value, c_null_ptr)) + end function set_function + + function write_body(chunk, element, count, userdata) & + bind(c, name='cepis_write_body') result(taken) + type(c_ptr), value :: chunk + integer(c_size_t), value :: element + integer(c_size_t), value :: count + type(c_ptr), value :: userdata + integer(c_size_t) :: taken + type(string_buffer), pointer :: buffer + + taken = element*count + if (taken <= 0_c_size_t) return + if (.not. c_associated(chunk) .or. .not. c_associated(userdata)) return + call c_f_pointer(userdata, buffer) + call buffer%append(bytes_at(chunk, int(taken))) + end function write_body + + function read_header(chunk, element, count, userdata) & + bind(c, name='cepis_read_header') result(taken) + type(c_ptr), value :: chunk + integer(c_size_t), value :: element + integer(c_size_t), value :: count + type(c_ptr), value :: userdata + integer(c_size_t) :: taken + type(header_state), pointer :: state + character(len=:), allocatable :: line + real(real64) :: seconds + logical :: understood + + taken = element*count + if (taken <= 0_c_size_t) return + if (.not. c_associated(chunk) .or. .not. c_associated(userdata)) return + + line = bytes_at(chunk, int(taken)) + if (.not. starts_with(lower(line), 'retry-after:')) return + + call http_parse_retry_after(line(13:), seconds, understood) + if (.not. understood) return + + call c_f_pointer(userdata, state) + state%retry_after = seconds + end function read_header + + function bytes_at(address, length) result(text) + type(c_ptr), intent(in) :: address + integer, intent(in) :: length + character(len=:), allocatable :: text + character(kind=c_char), pointer :: raw(:) + integer :: i + + allocate (character(len=length) :: text) + call c_f_pointer(address, raw, [length]) + do i = 1, length + text(i:i) = raw(i) + end do + end function bytes_at + + !> Read a `Retry-After` value in either RFC 9110 form. + !> + !> It arrives as a number of seconds (`120`) or as an HTTP date + !> (`Wed, 21 Oct 2026 07:28:00 GMT`). Handling only the first is the common + !> bug, and it makes a client ignore exactly the wait request that matters + !> most. A date already in the past yields zero, never a negative wait. + subroutine http_parse_retry_after(text, seconds, ok) + character(len=*), intent(in) :: text + real(real64), intent(out) :: seconds + logical, intent(out) :: ok + character(len=:), allocatable :: value + integer(int64) :: target_epoch + + seconds = 0.0_real64 + ok = .false. + value = strip(text) + if (len(value) == 0) return + + if (is_digits(value)) then + call parse_real(value, seconds, ok) + if (ok) seconds = max(0.0_real64, seconds) + return + end if + + call parse_http_date(value, target_epoch, ok) + if (.not. ok) return + seconds = max(0.0_real64, real(target_epoch - int(c_time(c_null_ptr), int64), real64)) + end subroutine http_parse_retry_after + + subroutine parse_http_date(text, epoch, ok) + character(len=*), intent(in) :: text + integer(int64), intent(out) :: epoch + logical, intent(out) :: ok + character(len=*), parameter :: months = 'JanFebMarAprMayJunJulAugSepOctNovDec' + character(len=:), allocatable :: value + integer :: comma, month, i + integer :: day, year, hour, minute, second + integer :: ios + + epoch = 0_int64 + ok = .false. + + value = strip(text) + comma = index(value, ',') + if (comma > 0) value = strip(value(comma + 1:)) + if (len(value) < 20) return + + read (value(1:2), '(I2)', iostat=ios) day + if (ios /= 0) return + + month = 0 + do i = 1, 12 + if (value(4:6) == months(3*i - 2:3*i)) then + month = i + exit + end if + end do + if (month == 0) return + + read (value(8:11), '(I4)', iostat=ios) year + if (ios /= 0) return + read (value(13:14), '(I2)', iostat=ios) hour + if (ios /= 0) return + read (value(16:17), '(I2)', iostat=ios) minute + if (ios /= 0) return + read (value(19:20), '(I2)', iostat=ios) second + if (ios /= 0) return + + epoch = days_from_civil(year, month, day)*86400_int64 + & + int(hour, int64)*3600_int64 + int(minute, int64)*60_int64 + & + int(second, int64) + ok = .true. + end subroutine parse_http_date + + pure function days_from_civil(year, month, day) result(days) + integer, intent(in) :: year + integer, intent(in) :: month + integer, intent(in) :: day + integer(int64) :: days + integer(int64) :: y, era, year_of_era, day_of_year, day_of_era + integer(int64) :: m, d + + y = int(year, int64) + m = int(month, int64) + d = int(day, int64) + if (m <= 2_int64) y = y - 1_int64 + + if (y >= 0_int64) then + era = y/400_int64 + else + era = (y - 399_int64)/400_int64 + end if + year_of_era = y - era*400_int64 + + if (m > 2_int64) then + day_of_year = (153_int64*(m - 3_int64) + 2_int64)/5_int64 + d - 1_int64 + else + day_of_year = (153_int64*(m + 9_int64) + 2_int64)/5_int64 + d - 1_int64 + end if + + day_of_era = year_of_era*365_int64 + year_of_era/4_int64 - & + year_of_era/100_int64 + day_of_year + days = era*146097_int64 + day_of_era - 719468_int64 + end function days_from_civil + + !> Sleep for `seconds`, sub-second resolution included. + subroutine http_sleep(seconds) + real(real64), intent(in) :: seconds + type(c_timespec) :: request + integer(c_int) :: rc + + if (seconds <= 0.0_real64) return + request%tv_sec = int(seconds, c_long) + request%tv_nsec = int((seconds - real(request%tv_sec, real64))*1.0e9_real64, c_long) + if (request%tv_nsec < 0_c_long) request%tv_nsec = 0_c_long + if (request%tv_nsec > 999999999_c_long) request%tv_nsec = 999999999_c_long + rc = c_nanosleep(request, c_null_ptr) + end subroutine http_sleep + + !> Seconds on a monotonic clock. Only differences are meaningful. + function http_monotonic() result(seconds) + real(real64) :: seconds + integer(int64) :: ticks, rate + + call system_clock(ticks, rate) + if (rate <= 0_int64) then + seconds = 0.0_real64 + else + seconds = real(ticks, real64)/real(rate, real64) + end if + end function http_monotonic + +end module cepis_http diff --git a/src/cepis_json.f90 b/src/cepis_json.f90 new file mode 100644 index 0000000..b7be02e --- /dev/null +++ b/src/cepis_json.f90 @@ -0,0 +1,635 @@ +!> A small, strict JSON reader. +!> +!> Fortran ships no JSON parser, so this is hand-written. It is a complete +!> RFC 8259 reader for the shapes the API produces: objects, arrays, strings +!> with `\u` escapes and surrogate pairs, numbers, `true`, `false` and `null`. +!> +!> Values live in one growable array inside a `json_document` and are referred +!> to by integer index. That keeps the type free of recursive allocatable +!> components, and it means no reference into the document can dangle when the +!> array grows during parsing. +module cepis_json + use, intrinsic :: iso_fortran_env, only: real64, int64 + use cepis_strings, only: string_buffer, from_real, from_integer, parse_real, utf8_encode + implicit none + private + + character, parameter :: BACKSLASH = char(92) + + integer, parameter, public :: JSON_NULL = 0 + integer, parameter, public :: JSON_BOOL = 1 + integer, parameter, public :: JSON_NUMBER = 2 + integer, parameter, public :: JSON_STRING = 3 + integer, parameter, public :: JSON_ARRAY = 4 + integer, parameter, public :: JSON_OBJECT = 5 + + !> One `"name": value` pair of an object. + type, public :: json_member + character(len=:), allocatable :: name + integer :: node = 0 + end type json_member + + !> One JSON value. + type, public :: json_node + integer :: kind = JSON_NULL + character(len=:), allocatable :: text + real(real64) :: number = 0.0_real64 + logical :: truth = .false. + type(json_member), allocatable :: members(:) + integer, allocatable :: items(:) + end type json_node + + !> A parsed document. `root` indexes the top-level value. + type, public :: json_document + type(json_node), allocatable :: nodes(:) + integer :: used = 0 + integer :: root = 0 + contains + !> The kind of a node; `JSON_NULL` for an index of zero. + procedure :: kind_of + !> Index of the value of `name` inside object `node`, or zero. + procedure :: member + !> `.true.` when object `node` carries `name`. + procedure :: has + !> A node as text. Numbers and booleans are rendered; other kinds and + !> a zero index give the empty string, never a failure. + procedure :: text_of + !> A node as a floating-point value; zero when it is not a number. + procedure :: number_of + !> A node as an integer; zero when it is not a number. + procedure :: integer_of + !> `text_of` applied to a named member of an object. + procedure :: field_text + !> `number_of` applied to a named member of an object. + procedure :: field_number + !> `integer_of` applied to a named member of an object. + procedure :: field_integer + end type json_document + + public :: json_parse + +contains + + !> Parse `text`. On failure `ok` is `.false.` and `message` says why. + subroutine json_parse(text, doc, ok, message) + character(len=*), intent(in) :: text + type(json_document), intent(out) :: doc + logical, intent(out) :: ok + character(len=:), allocatable, intent(out) :: message + integer :: pos + + message = '' + pos = 1 + call skip_space(text, pos) + call parse_value(doc, text, pos, doc%root, ok, message) + if (.not. ok) return + call skip_space(text, pos) + if (pos <= len(text)) then + ok = .false. + message = 'trailing characters after the JSON value' + end if + end subroutine json_parse + + pure function kind_of(self, node) result(kind) + class(json_document), intent(in) :: self + integer, intent(in) :: node + integer :: kind + + if (node <= 0 .or. node > self%used) then + kind = JSON_NULL + else + kind = self%nodes(node)%kind + end if + end function kind_of + + pure function member(self, node, name) result(index) + class(json_document), intent(in) :: self + integer, intent(in) :: node + character(len=*), intent(in) :: name + integer :: index, i + + index = 0 + if (self%kind_of(node) /= JSON_OBJECT) return + if (.not. allocated(self%nodes(node)%members)) return + do i = 1, size(self%nodes(node)%members) + if (self%nodes(node)%members(i)%name == name) then + index = self%nodes(node)%members(i)%node + return + end if + end do + end function member + + pure function has(self, node, name) result(yes) + class(json_document), intent(in) :: self + integer, intent(in) :: node + character(len=*), intent(in) :: name + logical :: yes + + yes = self%member(node, name) /= 0 + end function has + + pure function text_of(self, node) result(text) + class(json_document), intent(in) :: self + integer, intent(in) :: node + character(len=:), allocatable :: text + + text = '' + select case (self%kind_of(node)) + case (JSON_STRING) + if (allocated(self%nodes(node)%text)) text = self%nodes(node)%text + case (JSON_NUMBER) + if (abs(self%nodes(node)%number - aint(self%nodes(node)%number)) < & + 1.0e-9_real64 .and. abs(self%nodes(node)%number) < 1.0e15_real64) then + text = from_integer(int(self%nodes(node)%number, int64)) + else + text = from_real(self%nodes(node)%number) + end if + case (JSON_BOOL) + if (self%nodes(node)%truth) then + text = 'true' + else + text = 'false' + end if + end select + end function text_of + + pure function number_of(self, node) result(value) + class(json_document), intent(in) :: self + integer, intent(in) :: node + real(real64) :: value + + value = 0.0_real64 + if (self%kind_of(node) == JSON_NUMBER) value = self%nodes(node)%number + end function number_of + + pure function integer_of(self, node) result(value) + class(json_document), intent(in) :: self + integer, intent(in) :: node + integer(int64) :: value + + value = 0_int64 + if (self%kind_of(node) == JSON_NUMBER) then + value = int(self%nodes(node)%number, int64) + end if + end function integer_of + + pure function field_text(self, node, name) result(text) + class(json_document), intent(in) :: self + integer, intent(in) :: node + character(len=*), intent(in) :: name + character(len=:), allocatable :: text + + text = self%text_of(self%member(node, name)) + end function field_text + + pure function field_number(self, node, name) result(value) + class(json_document), intent(in) :: self + integer, intent(in) :: node + character(len=*), intent(in) :: name + real(real64) :: value + + value = self%number_of(self%member(node, name)) + end function field_number + + pure function field_integer(self, node, name) result(value) + class(json_document), intent(in) :: self + integer, intent(in) :: node + character(len=*), intent(in) :: name + integer(int64) :: value + + value = self%integer_of(self%member(node, name)) + end function field_integer + + subroutine new_node(doc, index) + type(json_document), intent(inout) :: doc + integer, intent(out) :: index + type(json_node), allocatable :: bigger(:) + + if (.not. allocated(doc%nodes)) allocate (doc%nodes(16)) + if (doc%used >= size(doc%nodes)) then + allocate (bigger(2*size(doc%nodes))) + bigger(1:doc%used) = doc%nodes(1:doc%used) + call move_alloc(bigger, doc%nodes) + end if + doc%used = doc%used + 1 + index = doc%used + end subroutine new_node + + pure subroutine skip_space(text, pos) + character(len=*), intent(in) :: text + integer, intent(inout) :: pos + + do while (pos <= len(text)) + select case (text(pos:pos)) + case (' ', char(9), char(10), char(13)) + pos = pos + 1 + case default + return + end select + end do + end subroutine skip_space + + recursive subroutine parse_value(doc, text, pos, node, ok, message) + type(json_document), intent(inout) :: doc + character(len=*), intent(in) :: text + integer, intent(inout) :: pos + integer, intent(out) :: node + logical, intent(out) :: ok + character(len=:), allocatable, intent(out) :: message + + node = 0 + ok = .false. + message = '' + + call skip_space(text, pos) + if (pos > len(text)) then + message = 'unexpected end of input' + return + end if + + select case (text(pos:pos)) + case ('{') + call parse_object(doc, text, pos, node, ok, message) + case ('[') + call parse_array(doc, text, pos, node, ok, message) + case ('"') + block + character(len=:), allocatable :: value + call parse_string(text, pos, value, ok, message) + if (.not. ok) return + call new_node(doc, node) + doc%nodes(node)%kind = JSON_STRING + doc%nodes(node)%text = value + end block + case ('t') + call parse_literal(doc, text, pos, 'true', node, ok, message) + case ('f') + call parse_literal(doc, text, pos, 'false', node, ok, message) + case ('n') + call parse_literal(doc, text, pos, 'null', node, ok, message) + case default + call parse_number(doc, text, pos, node, ok, message) + end select + end subroutine parse_value + + subroutine parse_literal(doc, text, pos, word, node, ok, message) + type(json_document), intent(inout) :: doc + character(len=*), intent(in) :: text + integer, intent(inout) :: pos + character(len=*), intent(in) :: word + integer, intent(out) :: node + logical, intent(out) :: ok + character(len=:), allocatable, intent(out) :: message + + node = 0 + ok = .false. + message = '' + if (pos + len(word) - 1 > len(text)) then + message = 'truncated literal' + return + end if + if (text(pos:pos + len(word) - 1) /= word) then + message = 'unknown literal at position '//from_integer(int(pos, int64)) + return + end if + pos = pos + len(word) + + call new_node(doc, node) + select case (word) + case ('true') + doc%nodes(node)%kind = JSON_BOOL + doc%nodes(node)%truth = .true. + case ('false') + doc%nodes(node)%kind = JSON_BOOL + doc%nodes(node)%truth = .false. + case default + doc%nodes(node)%kind = JSON_NULL + end select + ok = .true. + end subroutine parse_literal + + subroutine parse_number(doc, text, pos, node, ok, message) + type(json_document), intent(inout) :: doc + character(len=*), intent(in) :: text + integer, intent(inout) :: pos + integer, intent(out) :: node + logical, intent(out) :: ok + character(len=:), allocatable, intent(out) :: message + integer :: first + real(real64) :: value + + node = 0 + ok = .false. + message = '' + first = pos + + if (text(pos:pos) == '-') pos = pos + 1 + do while (pos <= len(text)) + select case (text(pos:pos)) + case ('0':'9', '.', 'e', 'E', '+', '-') + pos = pos + 1 + case default + exit + end select + end do + + if (pos == first) then + message = 'unexpected character '''//text(pos:pos)//'''' + return + end if + + call parse_real(text(first:pos - 1), value, ok) + if (.not. ok) then + message = 'malformed number '''//text(first:pos - 1)//'''' + return + end if + + call new_node(doc, node) + doc%nodes(node)%kind = JSON_NUMBER + doc%nodes(node)%number = value + end subroutine parse_number + + subroutine parse_string(text, pos, value, ok, message) + character(len=*), intent(in) :: text + integer, intent(inout) :: pos + character(len=:), allocatable, intent(out) :: value + logical, intent(out) :: ok + character(len=:), allocatable, intent(out) :: message + type(string_buffer) :: out + integer :: code, low + logical :: got + + value = '' + ok = .false. + message = '' + pos = pos + 1 + + do + if (pos > len(text)) then + message = 'unterminated string' + return + end if + + if (text(pos:pos) == '"') then + pos = pos + 1 + value = out%text() + ok = .true. + return + else if (text(pos:pos) /= BACKSLASH) then + call out%append(text(pos:pos)) + pos = pos + 1 + cycle + end if + + pos = pos + 1 + if (pos > len(text)) then + message = 'unterminated escape' + return + end if + + select case (text(pos:pos)) + case ('"') + call out%append('"') + case (BACKSLASH) + call out%append(BACKSLASH) + case ('/') + call out%append('/') + case ('b') + call out%append(char(8)) + case ('f') + call out%append(char(12)) + case ('n') + call out%append(char(10)) + case ('r') + call out%append(char(13)) + case ('t') + call out%append(char(9)) + case ('u') + call read_hex4(text, pos + 1, code, got) + if (.not. got) then + message = 'malformed unicode escape' + return + end if + pos = pos + 4 + if (code >= 55296 .and. code <= 56319) then + if (pos + 6 <= len(text)) then + if (text(pos + 1:pos + 1) == BACKSLASH .and. & + text(pos + 2:pos + 2) == 'u') then + call read_hex4(text, pos + 3, low, got) + if (got .and. low >= 56320 .and. low <= 57343) then + code = 65536 + (code - 55296)*1024 + & + (low - 56320) + pos = pos + 6 + end if + end if + end if + end if + call out%append(utf8_encode(code)) + case default + message = 'unknown escape sequence' + return + end select + pos = pos + 1 + end do + end subroutine parse_string + + pure subroutine read_hex4(text, at, code, ok) + character(len=*), intent(in) :: text + integer, intent(in) :: at + integer, intent(out) :: code + logical, intent(out) :: ok + integer :: i, digit + + code = 0 + ok = .false. + if (at + 3 > len(text)) return + do i = at, at + 3 + select case (text(i:i)) + case ('0':'9') + digit = iachar(text(i:i)) - 48 + case ('a':'f') + digit = iachar(text(i:i)) - 87 + case ('A':'F') + digit = iachar(text(i:i)) - 55 + case default + return + end select + code = code*16 + digit + end do + ok = .true. + end subroutine read_hex4 + + recursive subroutine parse_array(doc, text, pos, node, ok, message) + type(json_document), intent(inout) :: doc + character(len=*), intent(in) :: text + integer, intent(inout) :: pos + integer, intent(out) :: node + logical, intent(out) :: ok + character(len=:), allocatable, intent(out) :: message + integer, allocatable :: items(:), bigger(:) + integer :: count, child + + node = 0 + ok = .false. + message = '' + allocate (items(8)) + count = 0 + pos = pos + 1 + + call skip_space(text, pos) + if (pos <= len(text)) then + if (text(pos:pos) == ']') then + pos = pos + 1 + call finish_array(doc, items, count, node) + ok = .true. + return + end if + end if + + do + call parse_value(doc, text, pos, child, ok, message) + if (.not. ok) return + if (count >= size(items)) then + allocate (bigger(2*size(items))) + bigger(1:count) = items(1:count) + call move_alloc(bigger, items) + end if + count = count + 1 + items(count) = child + + call skip_space(text, pos) + if (pos > len(text)) then + ok = .false. + message = 'unterminated array' + return + end if + if (text(pos:pos) == ',') then + pos = pos + 1 + cycle + else if (text(pos:pos) == ']') then + pos = pos + 1 + call finish_array(doc, items, count, node) + ok = .true. + return + else + ok = .false. + message = 'expected '','' or '']'' in array' + return + end if + end do + end subroutine parse_array + + subroutine finish_array(doc, items, count, node) + type(json_document), intent(inout) :: doc + integer, intent(in) :: items(:) + integer, intent(in) :: count + integer, intent(out) :: node + + call new_node(doc, node) + doc%nodes(node)%kind = JSON_ARRAY + allocate (doc%nodes(node)%items(count)) + if (count > 0) doc%nodes(node)%items = items(1:count) + end subroutine finish_array + + recursive subroutine parse_object(doc, text, pos, node, ok, message) + type(json_document), intent(inout) :: doc + character(len=*), intent(in) :: text + integer, intent(inout) :: pos + integer, intent(out) :: node + logical, intent(out) :: ok + character(len=:), allocatable, intent(out) :: message + type(json_member), allocatable :: members(:), bigger(:) + character(len=:), allocatable :: name + integer :: count, child + + node = 0 + ok = .false. + message = '' + allocate (members(8)) + count = 0 + pos = pos + 1 + + call skip_space(text, pos) + if (pos <= len(text)) then + if (text(pos:pos) == '}') then + pos = pos + 1 + call finish_object(doc, members, count, node) + ok = .true. + return + end if + end if + + do + call skip_space(text, pos) + if (pos > len(text)) then + message = 'unterminated object' + return + end if + if (text(pos:pos) /= '"') then + message = 'expected a string key in object' + return + end if + + call parse_string(text, pos, name, ok, message) + if (.not. ok) return + + call skip_space(text, pos) + if (pos > len(text)) then + ok = .false. + message = 'unterminated object' + return + end if + if (text(pos:pos) /= ':') then + ok = .false. + message = 'expected '':'' after key '''//name//'''' + return + end if + pos = pos + 1 + + call parse_value(doc, text, pos, child, ok, message) + if (.not. ok) return + + if (count >= size(members)) then + allocate (bigger(2*size(members))) + bigger(1:count) = members(1:count) + call move_alloc(bigger, members) + end if + count = count + 1 + members(count)%name = name + members(count)%node = child + + call skip_space(text, pos) + if (pos > len(text)) then + ok = .false. + message = 'unterminated object' + return + end if + if (text(pos:pos) == ',') then + pos = pos + 1 + cycle + else if (text(pos:pos) == '}') then + pos = pos + 1 + call finish_object(doc, members, count, node) + ok = .true. + return + else + ok = .false. + message = 'expected '','' or ''}'' in object' + return + end if + end do + end subroutine parse_object + + subroutine finish_object(doc, members, count, node) + type(json_document), intent(inout) :: doc + type(json_member), intent(in) :: members(:) + integer, intent(in) :: count + integer, intent(out) :: node + + call new_node(doc, node) + doc%nodes(node)%kind = JSON_OBJECT + allocate (doc%nodes(node)%members(count)) + if (count > 0) doc%nodes(node)%members = members(1:count) + end subroutine finish_object + +end module cepis_json diff --git a/src/cepis_models.f90 b/src/cepis_models.f90 new file mode 100644 index 0000000..c50d206 --- /dev/null +++ b/src/cepis_models.f90 @@ -0,0 +1,289 @@ +!> The data the API returns, as derived types. +!> +!> **Field names are the API's own, in Portuguese** — `logradouro`, `bairro`, +!> `localidade`. Everything else in this library is English; the fields are the +!> one deliberate exception. +!> +!> The reason is fidelity: what you read in the JSON at +!> https://cep.is/01001000 is exactly what you access on the derived type. +!> Translating to `street`/`city` would mean maintaining a field-by-field +!> mapping and forcing anyone reading the API docs alongside this library to +!> translate back in their head. The values are Portuguese either way — they +!> come from the Correios database. +module cepis_models + use, intrinsic :: iso_fortran_env, only: real64, int64 + use cepis_json, only: json_document, JSON_NUMBER, JSON_STRING, JSON_OBJECT + use cepis_strings, only: parse_real, is_digits + implicit none + private + + public :: cepis_geo + public :: cepis_address + public :: cepis_health + public :: address_clear + public :: address_from_json + public :: health_from_json + public :: cepis_format_cep + + !> The CEP's coordinate, when the database has one. + !> + !> The point is the **median** of the coordinates of that CEP's addresses, + !> not the mean: one badly geocoded address 40 km away shifts a mean and + !> does not move a median. + !> + !> Always check `precisao` before using `lat`/`lon` for distance: + !> + !> - `"logradouro"`: the point is a stretch of street. `raio_m` lands + !> around 100-150 m. Good for maps and for distance. + !> - `"localidade"`: the CEP *is* the whole municipality (a city-wide + !> general CEP) and the point is its centroid. `raio_m` runs from 7 km to + !> 40 km. Computing shipping from this is wrong by tens of kilometres. + !> + !> `raio_m` is the radius containing 90% of that CEP's addresses. It exists + !> precisely so that error cannot pass unnoticed. + type :: cepis_geo + !> Latitude in decimal degrees. + real(real64) :: lat = 0.0_real64 + !> Longitude in decimal degrees. + real(real64) :: lon = 0.0_real64 + !> Radius in metres containing 90% of the CEP's addresses. + integer :: raio_m = 0 + !> `"logradouro"` or `"localidade"`. + character(len=:), allocatable :: precisao + contains + !> `.true.` when the coordinate points at a street, not a + !> municipality. Shorthand for `precisao == 'logradouro'`, which is the + !> check to make before using the point to measure distance. + procedure :: is_precise + end type cepis_geo + + !> A CEP and everything the database knows about it. + !> + !> Every character component is allocated after any successful call. Fields + !> the database does not have for that CEP are the empty string, never + !> unallocated — that is what the API returns, and changing it here would + !> create a difference between reading the JSON and reading this library. + !> + !> `geo` is the exception, and it is guarded by `has_geo` rather than by an + !> unallocated component: the API **omits** the whole field when there is + !> no coordinate (about 43% of CEPs) rather than sending null, and a flag + !> makes the check impossible to forget. + type :: cepis_address + !> `.false.` for a CEP that the batch did not resolve. Always `.true.` + !> for an address that came back from a single lookup. + logical :: found = .false. + !> The 8 digits, unmasked. + character(len=:), allocatable :: cep + character(len=:), allocatable :: logradouro + character(len=:), allocatable :: complemento + character(len=:), allocatable :: unidade + character(len=:), allocatable :: bairro + character(len=:), allocatable :: localidade + !> Two-letter state code, e.g. `SP`. + character(len=:), allocatable :: uf + character(len=:), allocatable :: estado + character(len=:), allocatable :: regiao + !> IBGE municipality code. + character(len=:), allocatable :: ibge + character(len=:), allocatable :: gia + character(len=:), allocatable :: ddd + character(len=:), allocatable :: siafi + !> `.true.` when `geo` carries a coordinate. + logical :: has_geo = .false. + !> The coordinate. Meaningful only when `has_geo` is `.true.`. + type(cepis_geo) :: geo + !> The response body exactly as it arrived, uninterpreted, so a field + !> the API grows before this library is updated is not lost. Empty for + !> addresses that came from a batch, whose transport is CSV. + character(len=:), allocatable :: raw + contains + !> The CEP with its mask: `01001-000`. Empty when `cep` is not 8 + !> digits. + procedure :: formatted_cep + end type cepis_address + + !> The response of `GET /health`. + !> + !> Good for two things: checking that the API answers, and knowing **which + !> version of the database** is live. The DNE database changes every two + !> weeks; `dne` identifies it. + type :: cepis_health + !> `ok` when the API reports itself healthy. + character(len=:), allocatable :: status + !> Identifier of the fortnightly DNE database. + character(len=:), allocatable :: dne + !> CEPs in the database. + integer(int64) :: ceps = 0_int64 + !> CEPs that carry a coordinate. + integer(int64) :: geo = 0_int64 + !> ISO-8601 timestamp of the database build. + character(len=:), allocatable :: base_gerada_em + contains + !> `.true.` when the API reports itself healthy. + procedure :: ok => health_ok + end type cepis_health + +contains + + pure function is_precise(self) result(yes) + class(cepis_geo), intent(in) :: self + logical :: yes + + yes = .false. + if (allocated(self%precisao)) yes = self%precisao == 'logradouro' + end function is_precise + + pure function health_ok(self) result(yes) + class(cepis_health), intent(in) :: self + logical :: yes + + yes = .false. + if (allocated(self%status)) yes = self%status == 'ok' + end function health_ok + + pure function formatted_cep(self) result(text) + class(cepis_address), intent(in) :: self + character(len=:), allocatable :: text + + text = '' + if (.not. allocated(self%cep)) return + text = cepis_format_cep(self%cep) + end function formatted_cep + + !> Write the CEP with its mask: `01001-000`. + !> + !> The native contract always returns it unmasked; formatting is + !> presentation, and it lives here so it does not become a repeated + !> `write` in every project that uses this. Empty for anything that is not + !> 8 digits. + pure function cepis_format_cep(cep) result(text) + character(len=*), intent(in) :: cep + character(len=:), allocatable :: text + + text = '' + if (len(cep) /= 8) return + if (.not. is_digits(cep)) return + text = cep(1:5)//'-'//cep(6:8) + end function cepis_format_cep + + !> Reset an address to empty strings and no coordinate. + !> + !> Every character component ends up allocated, so a caller can read any of + !> them without checking `allocated` first. + pure subroutine address_clear(address) + type(cepis_address), intent(out) :: address + + address%found = .false. + address%cep = '' + address%logradouro = '' + address%complemento = '' + address%unidade = '' + address%bairro = '' + address%localidade = '' + address%uf = '' + address%estado = '' + address%regiao = '' + address%ibge = '' + address%gia = '' + address%ddd = '' + address%siafi = '' + address%has_geo = .false. + address%raw = '' + end subroutine address_clear + + !> Build an address from a parsed JSON object. + !> + !> Unknown fields are ignored but preserved in `raw`, so a new field in the + !> API cannot break this library. A malformed `geo` block yields + !> `has_geo = .false.` rather than a failure: it is not worth losing the + !> whole address over, since the rest of the response is still useful. + subroutine address_from_json(doc, node, raw, address) + type(json_document), intent(in) :: doc + integer, intent(in) :: node + character(len=*), intent(in) :: raw + type(cepis_address), intent(out) :: address + + call address_clear(address) + address%found = .true. + address%raw = raw + + address%cep = doc%field_text(node, 'cep') + address%logradouro = doc%field_text(node, 'logradouro') + address%complemento = doc%field_text(node, 'complemento') + address%unidade = doc%field_text(node, 'unidade') + address%bairro = doc%field_text(node, 'bairro') + address%localidade = doc%field_text(node, 'localidade') + address%uf = doc%field_text(node, 'uf') + address%estado = doc%field_text(node, 'estado') + address%regiao = doc%field_text(node, 'regiao') + address%ibge = doc%field_text(node, 'ibge') + address%gia = doc%field_text(node, 'gia') + address%ddd = doc%field_text(node, 'ddd') + address%siafi = doc%field_text(node, 'siafi') + + call read_geo(doc, doc%member(node, 'geo'), address) + end subroutine address_from_json + + subroutine read_geo(doc, node, address) + type(json_document), intent(in) :: doc + integer, intent(in) :: node + type(cepis_address), intent(inout) :: address + real(real64) :: lat, lon, radius + logical :: ok + character(len=:), allocatable :: precisao + + address%has_geo = .false. + if (doc%kind_of(node) /= JSON_OBJECT) return + + call number_field(doc, node, 'lat', lat, ok) + if (.not. ok) return + call number_field(doc, node, 'lon', lon, ok) + if (.not. ok) return + call number_field(doc, node, 'raio_m', radius, ok) + if (.not. ok) return + + if (doc%kind_of(doc%member(node, 'precisao')) /= JSON_STRING) return + precisao = doc%field_text(node, 'precisao') + + address%geo%lat = lat + address%geo%lon = lon + address%geo%raio_m = int(radius) + address%geo%precisao = precisao + address%has_geo = .true. + end subroutine read_geo + + subroutine number_field(doc, node, name, value, ok) + type(json_document), intent(in) :: doc + integer, intent(in) :: node + character(len=*), intent(in) :: name + real(real64), intent(out) :: value + logical, intent(out) :: ok + integer :: child + + value = 0.0_real64 + ok = .false. + child = doc%member(node, name) + + select case (doc%kind_of(child)) + case (JSON_NUMBER) + value = doc%number_of(child) + ok = .true. + case (JSON_STRING) + call parse_real(doc%text_of(child), value, ok) + end select + end subroutine number_field + + !> Build a health report from a parsed JSON object. + subroutine health_from_json(doc, node, health) + type(json_document), intent(in) :: doc + integer, intent(in) :: node + type(cepis_health), intent(out) :: health + + health%status = doc%field_text(node, 'status') + health%dne = doc%field_text(node, 'dne') + health%ceps = doc%field_integer(node, 'ceps') + health%geo = doc%field_integer(node, 'geo') + health%base_gerada_em = doc%field_text(node, 'base_gerada_em') + end subroutine health_from_json + +end module cepis_models diff --git a/src/cepis_strings.f90 b/src/cepis_strings.f90 new file mode 100644 index 0000000..33b21dc --- /dev/null +++ b/src/cepis_strings.f90 @@ -0,0 +1,347 @@ +!> String helpers shared by the parsers and the HTTP layer. +!> +!> Every routine here works with `character(len=:), allocatable` values rather +!> than fixed-length buffers. A fixed buffer truncates silently, and a truncated +!> `logradouro` is a wrong answer that looks like a right one. +module cepis_strings + use, intrinsic :: iso_c_binding + use, intrinsic :: iso_fortran_env, only: real64, int64 + implicit none + private + + public :: string_buffer + public :: strip + public :: lower + public :: starts_with + public :: is_digits + public :: parse_real + public :: parse_integer + public :: from_integer + public :: from_real + public :: url_encode + public :: to_c_chars + public :: from_c_string + public :: utf8_encode + + integer, parameter :: SCAN_LIMIT = 1073741823 + + !> A growing character buffer. + !> + !> Capacity doubles, so appending a response chunk by chunk stays linear + !> instead of copying the whole body on every append. + type :: string_buffer + character(len=:), allocatable, private :: store + integer, private :: used = 0 + contains + !> Append a chunk. + procedure :: append => buffer_append + !> The contents so far, exactly `size()` characters long. + procedure :: text => buffer_text + !> How many characters are held. + procedure :: size => buffer_size + !> Drop the contents, keeping the capacity. + procedure :: reset => buffer_reset + end type string_buffer + +contains + + subroutine buffer_append(self, chunk) + class(string_buffer), intent(inout) :: self + character(len=*), intent(in) :: chunk + character(len=:), allocatable :: bigger + integer :: needed, capacity + + if (len(chunk) == 0) return + if (.not. allocated(self%store)) then + allocate (character(len=max(128, len(chunk))) :: self%store) + self%used = 0 + end if + + needed = self%used + len(chunk) + if (needed > len(self%store)) then + capacity = max(2*len(self%store), needed) + allocate (character(len=capacity) :: bigger) + if (self%used > 0) bigger(1:self%used) = self%store(1:self%used) + call move_alloc(bigger, self%store) + end if + + self%store(self%used + 1:needed) = chunk + self%used = needed + end subroutine buffer_append + + pure function buffer_text(self) result(text) + class(string_buffer), intent(in) :: self + character(len=:), allocatable :: text + + if (.not. allocated(self%store) .or. self%used <= 0) then + text = '' + else + text = self%store(1:self%used) + end if + end function buffer_text + + pure function buffer_size(self) result(n) + class(string_buffer), intent(in) :: self + integer :: n + + n = self%used + end function buffer_size + + subroutine buffer_reset(self) + class(string_buffer), intent(inout) :: self + + self%used = 0 + end subroutine buffer_reset + + !> Remove leading and trailing blanks, tabs, carriage returns and newlines. + pure function strip(text) result(out) + character(len=*), intent(in) :: text + character(len=:), allocatable :: out + integer :: first, last + + first = 1 + last = len(text) + do while (first <= last) + if (.not. is_space(text(first:first))) exit + first = first + 1 + end do + do while (last >= first) + if (.not. is_space(text(last:last))) exit + last = last - 1 + end do + + if (first > last) then + out = '' + else + out = text(first:last) + end if + end function strip + + pure function is_space(ch) result(yes) + character, intent(in) :: ch + logical :: yes + + yes = ch == ' ' .or. ch == char(9) .or. ch == char(10) .or. & + ch == char(13) .or. ch == char(11) .or. ch == char(12) + end function is_space + + !> ASCII lowercase. The values in the API are UTF-8 and are left alone; + !> this is only used on header names, which are ASCII by RFC 9110. + pure function lower(text) result(out) + character(len=*), intent(in) :: text + character(len=:), allocatable :: out + integer :: i, code + + out = text + do i = 1, len(out) + code = iachar(out(i:i)) + if (code >= 65 .and. code <= 90) out(i:i) = achar(code + 32) + end do + end function lower + + !> `.true.` when `text` begins with `prefix`. + pure function starts_with(text, prefix) result(yes) + character(len=*), intent(in) :: text + character(len=*), intent(in) :: prefix + logical :: yes + + yes = len(text) >= len(prefix) + if (yes) yes = text(1:len(prefix)) == prefix + end function starts_with + + !> `.true.` when `text` is one or more ASCII digits and nothing else. + pure function is_digits(text) result(yes) + character(len=*), intent(in) :: text + logical :: yes + integer :: i, code + + yes = len(text) > 0 + do i = 1, len(text) + code = iachar(text(i:i)) + if (code < 48 .or. code > 57) then + yes = .false. + return + end if + end do + end function is_digits + + !> Read a decimal number. `ok` is `.false.` when `text` is not one. + subroutine parse_real(text, value, ok) + character(len=*), intent(in) :: text + real(real64), intent(out) :: value + logical, intent(out) :: ok + character(len=:), allocatable :: token + integer :: ios, i, code + logical :: seen_digit + + value = 0.0_real64 + ok = .false. + token = strip(text) + if (len(token) == 0) return + + seen_digit = .false. + do i = 1, len(token) + code = iachar(token(i:i)) + if (code >= 48 .and. code <= 57) then + seen_digit = .true. + else if (token(i:i) == '+' .or. token(i:i) == '-' .or. & + token(i:i) == '.' .or. token(i:i) == 'e' .or. & + token(i:i) == 'E') then + cycle + else + return + end if + end do + if (.not. seen_digit) return + + read (token, *, iostat=ios) value + ok = ios == 0 + if (.not. ok) value = 0.0_real64 + end subroutine parse_real + + !> Read a decimal integer. `ok` is `.false.` when `text` is not one. + subroutine parse_integer(text, value, ok) + character(len=*), intent(in) :: text + integer(int64), intent(out) :: value + logical, intent(out) :: ok + character(len=:), allocatable :: token + integer :: ios + + value = 0_int64 + ok = .false. + token = strip(text) + if (len(token) == 0) return + if (token(1:1) == '+' .or. token(1:1) == '-') then + if (.not. is_digits(token(2:))) return + else if (.not. is_digits(token)) then + return + end if + + read (token, *, iostat=ios) value + ok = ios == 0 + if (.not. ok) value = 0_int64 + end subroutine parse_integer + + !> Decimal text for an integer, without the padding `write` would leave. + pure function from_integer(value) result(text) + integer(int64), intent(in) :: value + character(len=:), allocatable :: text + character(len=32) :: scratch + + write (scratch, '(I0)') value + text = trim(scratch) + end function from_integer + + !> Decimal text for a floating-point value, trailing zeros removed. + pure function from_real(value) result(text) + real(real64), intent(in) :: value + character(len=:), allocatable :: text + character(len=32) :: scratch + integer :: i + + write (scratch, '(F0.6)') value + text = trim(scratch) + if (index(text, '.') > 0) then + i = len(text) + do while (i > 1) + if (text(i:i) /= '0') exit + i = i - 1 + end do + if (text(i:i) == '.') i = i - 1 + text = text(1:i) + end if + if (starts_with(text, '.')) text = '0'//text + if (starts_with(text, '-.')) text = '-0'//text(2:) + end function from_real + + !> Percent-encode everything outside the RFC 3986 unreserved set. + pure function url_encode(text) result(out) + character(len=*), intent(in) :: text + character(len=:), allocatable :: out + character(len=*), parameter :: hex = '0123456789ABCDEF' + integer :: i, code + + out = '' + do i = 1, len(text) + code = iachar(text(i:i)) + if ((code >= 48 .and. code <= 57) .or. & + (code >= 65 .and. code <= 90) .or. & + (code >= 97 .and. code <= 122) .or. & + text(i:i) == '-' .or. text(i:i) == '_' .or. & + text(i:i) == '.' .or. text(i:i) == '~') then + out = out//text(i:i) + else + out = out//'%'//hex(code/16 + 1:code/16 + 1)// & + hex(mod(code, 16) + 1:mod(code, 16) + 1) + end if + end do + end function url_encode + + !> A NUL-terminated `c_char` array, suitable for `c_loc` and libcurl. + !> + !> An array rather than a deferred-length scalar because `c_loc` rejects + !> anything carrying a length type parameter. + pure function to_c_chars(text) result(out) + character(len=*), intent(in) :: text + character(kind=c_char), allocatable :: out(:) + integer :: i + + allocate (out(len(text) + 1)) + do i = 1, len(text) + out(i) = text(i:i) + end do + out(len(text) + 1) = c_null_char + end function to_c_chars + + !> Copy a C string into a Fortran string. An empty string for `NULL`. + function from_c_string(ptr) result(text) + type(c_ptr), intent(in) :: ptr + character(len=:), allocatable :: text + character(kind=c_char), pointer :: chars(:) + integer :: n + + text = '' + if (.not. c_associated(ptr)) return + call c_f_pointer(ptr, chars, [SCAN_LIMIT]) + n = 0 + do while (chars(n + 1) /= c_null_char) + n = n + 1 + if (n >= SCAN_LIMIT - 1) exit + end do + if (n == 0) return + allocate (character(len=n) :: text) + block + integer :: i + do i = 1, n + text(i:i) = chars(i) + end do + end block + end function from_c_string + + !> Encode one Unicode code point as UTF-8 bytes. + !> + !> Used by the JSON reader for `\uXXXX` escapes. The API sends UTF-8 + !> directly, but a proxy or a re-encoder in the middle may not. + pure function utf8_encode(code) result(bytes) + integer, intent(in) :: code + character(len=:), allocatable :: bytes + + if (code < 0 .or. code > 1114111) then + bytes = char(239)//char(191)//char(189) + else if (code < 128) then + bytes = char(code) + else if (code < 2048) then + bytes = char(192 + code/64)//char(128 + mod(code, 64)) + else if (code < 65536) then + bytes = char(224 + code/4096)// & + char(128 + mod(code/64, 64))// & + char(128 + mod(code, 64)) + else + bytes = char(240 + code/262144)// & + char(128 + mod(code/4096, 64))// & + char(128 + mod(code/64, 64))// & + char(128 + mod(code, 64)) + end if + end function utf8_encode + +end module cepis_strings 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 |