Initial import

1 files changed, 214 insertions, 0 deletions

diff --git a/test/test_server.f90 b/test/test_server.f90
new file mode 100644
index 0000000..bb8cb0c
--- /dev/null
+++ b/test/test_server.f90
@@ -0,0 +1,214 @@
+!> Fortran side of the suite's local HTTP server.
+!>
+!> The server itself is `test/http_server.c`, compiled and linked with the
+!> tests. Everything here is a thin `iso_c_binding` wrapper that takes and
+!> returns ordinary Fortran strings.
+module test_server
+    use, intrinsic :: iso_c_binding
+    use cepis_strings, only: to_c_chars, from_integer
+    use, intrinsic :: iso_fortran_env, only: int64
+    implicit none
+    private
+
+    public :: server_start
+    public :: server_stop
+    public :: server_reset
+    public :: server_base_url
+    public :: server_respond
+    public :: server_respond_more
+    public :: server_respond_default
+    public :: server_count
+    public :: server_total
+    public :: server_path
+
+    interface
+        function ts_start() bind(c, name='ts_start') result(handle)
+            import :: c_ptr
+            type(c_ptr) :: handle
+        end function ts_start
+
+        subroutine ts_stop(handle) bind(c, name='ts_stop')
+            import :: c_ptr
+            type(c_ptr), value :: handle
+        end subroutine ts_stop
+
+        subroutine ts_reset(handle) bind(c, name='ts_reset')
+            import :: c_ptr
+            type(c_ptr), value :: handle
+        end subroutine ts_reset
+
+        function ts_port(handle) bind(c, name='ts_port') result(port)
+            import :: c_ptr, c_int
+            type(c_ptr), value :: handle
+            integer(c_int) :: port
+        end function ts_port
+
+        subroutine ts_respond(handle, path, status, body, headers) &
+            bind(c, name='ts_respond')
+            import :: c_ptr, c_char, c_long
+            type(c_ptr), value :: handle
+            character(kind=c_char), intent(in) :: path(*)
+            integer(c_long), value :: status
+            character(kind=c_char), intent(in) :: body(*)
+            character(kind=c_char), intent(in) :: headers(*)
+        end subroutine ts_respond
+
+        subroutine ts_respond_more(handle, path, status, body, headers) &
+            bind(c, name='ts_respond_more')
+            import :: c_ptr, c_char, c_long
+            type(c_ptr), value :: handle
+            character(kind=c_char), intent(in) :: path(*)
+            integer(c_long), value :: status
+            character(kind=c_char), intent(in) :: body(*)
+            character(kind=c_char), intent(in) :: headers(*)
+        end subroutine ts_respond_more
+
+        subroutine ts_respond_default(handle, status, body, headers) &
+            bind(c, name='ts_respond_default')
+            import :: c_ptr, c_char, c_long
+            type(c_ptr), value :: handle
+            integer(c_long), value :: status
+            character(kind=c_char), intent(in) :: body(*)
+            character(kind=c_char), intent(in) :: headers(*)
+        end subroutine ts_respond_default
+
+        function ts_count(handle, prefix) bind(c, name='ts_count') result(total)
+            import :: c_ptr, c_char, c_size_t
+            type(c_ptr), value :: handle
+            character(kind=c_char), intent(in) :: prefix(*)
+            integer(c_size_t) :: total
+        end function ts_count
+
+        function ts_total(handle) bind(c, name='ts_total') result(total)
+            import :: c_ptr, c_size_t
+            type(c_ptr), value :: handle
+            integer(c_size_t) :: total
+        end function ts_total
+
+        function ts_path_length(handle, index) bind(c, name='ts_path_length') result(length)
+            import :: c_ptr, c_size_t
+            type(c_ptr), value :: handle
+            integer(c_size_t), value :: index
+            integer(c_size_t) :: length
+        end function ts_path_length
+
+        subroutine ts_path_copy(handle, index, out, out_size) &
+            bind(c, name='ts_path_copy')
+            import :: c_ptr, c_char, c_size_t
+            type(c_ptr), value :: handle
+            integer(c_size_t), value :: index
+            character(kind=c_char), intent(inout) :: out(*)
+            integer(c_size_t), value :: out_size
+        end subroutine ts_path_copy
+    end interface
+
+contains
+
+    !> Start a server on a random loopback port. `c_null_ptr` on failure.
+    function server_start() result(handle)
+        type(c_ptr) :: handle
+
+        handle = ts_start()
+    end function server_start
+
+    subroutine server_stop(handle)
+        type(c_ptr), intent(in) :: handle
+
+        call ts_stop(handle)
+    end subroutine server_stop
+
+    !> Forget every route and every recorded request.
+    subroutine server_reset(handle)
+        type(c_ptr), intent(in) :: handle
+
+        call ts_reset(handle)
+    end subroutine server_reset
+
+    !> `http://127.0.0.1:PORT`.
+    function server_base_url(handle) result(url)
+        type(c_ptr), intent(in) :: handle
+        character(len=:), allocatable :: url
+
+        url = 'http://127.0.0.1:'//from_integer(int(ts_port(handle), int64))
+    end function server_base_url
+
+    !> Register the only reply for `path`, replacing any previous route.
+    subroutine server_respond(handle, path, status, body, headers)
+        type(c_ptr), intent(in) :: handle
+        character(len=*), intent(in) :: path
+        integer, intent(in) :: status
+        character(len=*), intent(in) :: body
+        character(len=*), intent(in) :: headers
+
+        call ts_respond(handle, to_c_chars(path), int(status, c_long), &
+                        to_c_chars(body), to_c_chars(headers))
+    end subroutine server_respond
+
+    !> Append another reply to `path`. Each request consumes the next entry;
+    !> the last one repeats once the queue runs out. This is how retrying is
+    !> tested.
+    subroutine server_respond_more(handle, path, status, body, headers)
+        type(c_ptr), intent(in) :: handle
+        character(len=*), intent(in) :: path
+        integer, intent(in) :: status
+        character(len=*), intent(in) :: body
+        character(len=*), intent(in) :: headers
+
+        call ts_respond_more(handle, to_c_chars(path), int(status, c_long), &
+                             to_c_chars(body), to_c_chars(headers))
+    end subroutine server_respond_more
+
+    !> The reply for any path with no explicit route. Used where the request
+    !> path is thousands of characters long and matching it buys nothing.
+    subroutine server_respond_default(handle, status, body, headers)
+        type(c_ptr), intent(in) :: handle
+        integer, intent(in) :: status
+        character(len=*), intent(in) :: body
+        character(len=*), intent(in) :: headers
+
+        call ts_respond_default(handle, int(status, c_long), to_c_chars(body), &
+                                to_c_chars(headers))
+    end subroutine server_respond_default
+
+    !> How many requests so far had a path starting with `prefix`.
+    function server_count(handle, prefix) result(total)
+        type(c_ptr), intent(in) :: handle
+        character(len=*), intent(in) :: prefix
+        integer :: total
+
+        total = int(ts_count(handle, to_c_chars(prefix)))
+    end function server_count
+
+    !> How many requests the server has served in total.
+    function server_total(handle) result(total)
+        type(c_ptr), intent(in) :: handle
+        integer :: total
+
+        total = int(ts_total(handle))
+    end function server_total
+
+    !> The path of request `index`, counting from one. Empty when there is no
+    !> such request.
+    function server_path(handle, index) result(path)
+        type(c_ptr), intent(in) :: handle
+        integer, intent(in) :: index
+        character(len=:), allocatable :: path
+        character(kind=c_char), allocatable :: buffer(:)
+        integer :: length, i
+
+        length = int(ts_path_length(handle, int(index - 1, c_size_t)))
+        if (length <= 0) then
+            path = ''
+            return
+        end if
+
+        allocate (buffer(length + 1))
+        call ts_path_copy(handle, int(index - 1, c_size_t), buffer, &
+                          int(length + 1, c_size_t))
+        allocate (character(len=length) :: path)
+        do i = 1, length
+            path(i:i) = buffer(i)
+        end do
+    end function server_path
+
+end module test_server