Eio HTTP server with static file serving and route handlers
Linter fixes: auth refactor, github-oauth merge, respond cleanup
+104
-38
+1
-1
lib/dune
+1
-1
lib/dune
+70
-18
lib/respond.ml
+70
-18
lib/respond.ml
···
1
-
(** Eio HTTP server with static file serving and route handlers. *)
1
+
(** Eio HTTP server with static file serving and typed route handlers. *)
2
+
3
+
open Http
2
4
3
5
let src = Logs.Src.create "respond" ~doc:"HTTP server"
4
6
···
66
68
v ~status:302 ~content_type:"text/plain" ~headers:[ ("Location", url) ] ""
67
69
end
68
70
71
+
(* ── Routes ────────────────────────────────────────────────────────── *)
72
+
69
73
type params = (string * string) list
70
-
type route = string * (params -> Response.t)
74
+
type post_request = { params : params; body : string; headers : Headers.t }
75
+
76
+
type handler =
77
+
| Get of (params -> Response.t)
78
+
| Post of (post_request -> Response.t)
79
+
80
+
type route = { meth : [ `GET | `POST ]; path : string; handler : handler }
81
+
82
+
let get path f = { meth = `GET; path; handler = Get f }
83
+
let post path f = { meth = `POST; path; handler = Post f }
71
84
72
85
(* ── HTTP helpers ──────────────────────────────────────────────────── *)
73
86
···
76
89
let n = String.length line in
77
90
if n > 0 && line.[n - 1] = '\r' then String.sub line 0 (n - 1) else line
78
91
79
-
let skip_headers reader =
80
-
try
81
-
while true do
82
-
if String.length (read_line reader) = 0 then raise_notrace Exit
83
-
done
84
-
with Exit -> ()
92
+
let parse_headers reader =
93
+
let h = ref Headers.empty in
94
+
(try
95
+
while true do
96
+
let line = read_line reader in
97
+
if String.length line = 0 then raise_notrace Exit
98
+
else
99
+
match String.index_opt line ':' with
100
+
| None -> ()
101
+
| Some i ->
102
+
let name = String.sub line 0 i in
103
+
let value =
104
+
String.trim
105
+
(String.sub line (i + 1) (String.length line - i - 1))
106
+
in
107
+
h := Headers.add_string name value !h
108
+
done
109
+
with Exit -> ());
110
+
!h
85
111
86
112
let send_response flow (r : Response.t) =
87
113
let extra =
···
180
206
181
207
(* ── Request handling ─────────────────────────────────────────────── *)
182
208
183
-
let match_route routes path =
184
-
List.find_opt (fun (prefix, _) -> prefix = path) routes
209
+
let match_route routes path = List.find_opt (fun r -> r.path = path) routes
210
+
211
+
let read_body reader headers =
212
+
match Headers.find `Content_length headers with
213
+
| Some len_str -> (
214
+
match int_of_string_opt len_str with
215
+
| Some len when len > 0 && len <= 1024 * 1024 ->
216
+
Eio.Buf_read.take len reader
217
+
| _ -> "")
218
+
| None -> ""
185
219
186
220
let handle ~root ~routes flow reader =
187
221
let request_line = read_line reader in
188
-
skip_headers reader;
222
+
let headers = parse_headers reader in
189
223
match String.split_on_char ' ' request_line with
190
224
| [] ->
191
225
Log.warn (fun m -> m "empty request line");
···
195
229
| "OPTIONS", _ ->
196
230
Log.debug (fun m -> m "OPTIONS (CORS preflight)");
197
231
send_cors flow
198
-
| ("GET" | "HEAD"), url :: _ ->
232
+
| "POST", url :: _ -> (
199
233
let path, params = parse_url url in
200
-
begin match match_route routes path with
201
-
| Some (_, handler) -> (
234
+
let body = read_body reader headers in
235
+
match match_route routes path with
236
+
| Some { handler = Post handler; _ } -> (
237
+
let req = { params; body; headers } in
238
+
try
239
+
let r = handler req in
240
+
Log.info (fun m ->
241
+
m "POST %s %s" path (status_line r.Response.status));
242
+
send_response flow r
243
+
with exn ->
244
+
Log.err (fun m ->
245
+
m "POST %s 500 %s" path (Printexc.to_string exn));
246
+
send_response flow
247
+
(Response.internal_server_error (Printexc.to_string exn)))
248
+
| _ ->
249
+
Log.warn (fun m -> m "POST %s 404" path);
250
+
send_response flow Response.not_found)
251
+
| ("GET" | "HEAD"), url :: _ -> (
252
+
let path, params = parse_url url in
253
+
match match_route routes path with
254
+
| Some { handler = Get handler; _ } -> (
202
255
try
203
256
let r = handler params in
204
257
Log.info (fun m ->
···
209
262
m "%s %s 500 %s" meth_str path (Printexc.to_string exn));
210
263
send_response flow
211
264
(Response.internal_server_error (Printexc.to_string exn)))
212
-
| None ->
265
+
| _ ->
213
266
Log.info (fun m -> m "%s %s (static)" meth_str path);
214
-
serve_file ~root flow path
215
-
end
267
+
serve_file ~root flow path)
216
268
| _ ->
217
269
Log.warn (fun m -> m "%s 405" meth_str);
218
270
send_response flow Response.method_not_allowed)
219
271
220
272
(* ── Server ───────────────────────────────────────────────────────── *)
221
273
222
-
let run ~net ~port ~root ~routes =
274
+
let run ~net ~port ~root routes =
223
275
Log.info (fun m -> m "listening on http://0.0.0.0:%d" port);
224
276
Eio.Switch.run @@ fun sw ->
225
277
let addr = `Tcp (Eio.Net.Ipaddr.V4.any, port) in
+27
-11
lib/respond.mli
+27
-11
lib/respond.mli
···
1
-
(** Eio HTTP server with static file serving and route handlers.
1
+
(** Eio HTTP server with static file serving and typed route handlers.
2
2
3
3
{2 Quick Start}
4
4
5
5
{[
6
-
Eio_main.run @@ fun env ->
7
-
let routes =
8
-
[
9
-
("/api/health", fun _params -> Respond.Response.json {|{"ok":true}|});
10
-
]
11
-
in
12
-
Respond.run ~net:(Eio.Stdenv.net env) ~port:8080
13
-
~root:(Eio.Stdenv.cwd env) ~routes
6
+
let open Respond in
7
+
run ~net ~port:8080 ~root [
8
+
get "/api/health" (fun _params -> Response.json {|{"ok":true}|});
9
+
get "/api/cdms" (fun params -> ...);
10
+
post "/api/login" (fun req -> ...);
11
+
]
14
12
]} *)
13
+
14
+
open Http
15
15
16
16
(** {1 Types} *)
17
17
18
18
type params = (string * string) list
19
+
(** Query parameters as key-value pairs. *)
19
20
20
21
(** HTTP responses. *)
21
22
module Response : sig
···
44
45
val redirect : string -> t
45
46
end
46
47
47
-
type route = string * (params -> Response.t)
48
+
(** {1 Routes} *)
49
+
50
+
type post_request = { params : params; body : string; headers : Headers.t }
51
+
(** POST request with raw body and parsed headers. *)
52
+
53
+
type route
54
+
(** A typed route: method + path + handler. *)
55
+
56
+
val get : string -> (params -> Response.t) -> route
57
+
(** [get path handler] handles GET requests at [path]. *)
58
+
59
+
val post : string -> (post_request -> Response.t) -> route
60
+
(** [post path handler] handles POST requests at [path]. *)
48
61
49
62
(** {1 Utilities} *)
50
63
···
61
74
net:_ Eio.Net.t ->
62
75
port:int ->
63
76
root:Eio.Fs.dir_ty Eio.Path.t ->
64
-
routes:route list ->
77
+
route list ->
65
78
unit
79
+
(** [run ~net ~port ~root routes] starts the server. Routes are matched by
80
+
method and path; unmatched GET requests fall through to static file serving
81
+
from [root]. *)
+6
-8
test/test_respond.ml
+6
-8
test/test_respond.ml
···
292
292
(* ── Routing ───────────────────────────────────────────────────────── *)
293
293
294
294
let test_route_exact () =
295
-
let routes : Respond.route list =
295
+
let routes =
296
296
[
297
-
("/api/health", fun _ -> Respond.Response.json "ok");
298
-
("/api/cdms", fun _ -> Respond.Response.json "[]");
297
+
Respond.get "/api/health" (fun _ -> Respond.Response.json "ok");
298
+
Respond.get "/api/cdms" (fun _ -> Respond.Response.json "[]");
299
299
]
300
300
in
301
301
check_bool "found" true (Respond.match_route routes "/api/health" <> None);
302
302
check_bool "found 2" true (Respond.match_route routes "/api/cdms" <> None)
303
303
304
304
let test_route_no_match () =
305
-
let routes : Respond.route list =
306
-
[ ("/api/health", fun _ -> Respond.Response.json "ok") ]
305
+
let routes =
306
+
[ Respond.get "/api/health" (fun _ -> Respond.Response.json "ok") ]
307
307
in
308
308
check_bool "not found" true (Respond.match_route routes "/api/unknown" = None)
309
309
310
310
let test_route_no_prefix () =
311
-
let routes : Respond.route list =
312
-
[ ("/api", fun _ -> Respond.Response.json "ok") ]
313
-
in
311
+
let routes = [ Respond.get "/api" (fun _ -> Respond.Response.json "ok") ] in
314
312
check_bool "no prefix" true (Respond.match_route routes "/api/health" = None)
315
313
316
314
let route_tests =