Initial import

1 files changed, 477 insertions, 0 deletions

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