1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
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
|