From 42d8c12d2bd88462df8c3aac9449abbf98400084 Mon Sep 17 00:00:00 2001 From: Murilo Ijanc Date: Sun, 26 Jul 2026 12:52:43 -0300 Subject: Initial import --- src/cepis.f90 | 693 ++++++++++++++++++++++++++++++++++++++++++++++++++ src/cepis_csv.f90 | 218 ++++++++++++++++ src/cepis_errors.f90 | 83 ++++++ src/cepis_http.f90 | 477 ++++++++++++++++++++++++++++++++++ src/cepis_json.f90 | 635 +++++++++++++++++++++++++++++++++++++++++++++ src/cepis_models.f90 | 289 +++++++++++++++++++++ src/cepis_strings.f90 | 347 +++++++++++++++++++++++++ 7 files changed, 2742 insertions(+) create mode 100644 src/cepis.f90 create mode 100644 src/cepis_csv.f90 create mode 100644 src/cepis_errors.f90 create mode 100644 src/cepis_http.f90 create mode 100644 src/cepis_json.f90 create mode 100644 src/cepis_models.f90 create mode 100644 src/cepis_strings.f90 (limited to 'src') 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 -- cgit v1.3