!> 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