path: root/src/cepis_http.f90

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