Eio HTTP server with static file serving and route handlers
Add ocaml-respond: Eio HTTP server with static file serving
Minimal HTTP/1.1 server reusing requests.core types (Status.t, Method.t,
Headers.t). Features: static file serving with MIME detection and ETag,
custom route handlers, structured logging via Logs, path traversal
prevention, CORS support.
89 tests covering RFC 7230-7235 compliance: URL parsing, path
normalization, status codes, HTTP methods, ETag generation, MIME
detection, header injection prevention, routing.
+1076
+4
lib/dune
+4
lib/dune
+212
lib/respond.ml
+212
lib/respond.ml
···
1
+
(** Eio HTTP server with static file serving and route handlers.
2
+
3
+
Reuses HTTP types (Method, Status, Headers) from requests. *)
4
+
5
+
let src = Logs.Src.create "respond" ~doc:"HTTP server"
6
+
7
+
module Log = (val Logs.src_log src : Logs.LOG)
8
+
9
+
(* ── Response ──────────────────────────────────────────────────────── *)
10
+
11
+
module Response = struct
12
+
type t = {
13
+
status : Status.t;
14
+
content_type : string;
15
+
body : string;
16
+
headers : (string * string) list;
17
+
}
18
+
19
+
let v ?(headers = []) ~status ~content_type body =
20
+
{ status; content_type; body; headers }
21
+
22
+
let json body = v ~status:`OK ~content_type:"application/json" body
23
+
let text body = v ~status:`OK ~content_type:"text/plain" body
24
+
let html body = v ~status:`OK ~content_type:"text/html; charset=utf-8" body
25
+
let raw ~status ~content_type body = v ~status ~content_type body
26
+
let not_found = v ~status:`Not_found ~content_type:"text/plain" "Not Found"
27
+
let bad_request msg = v ~status:`Bad_request ~content_type:"text/plain" msg
28
+
29
+
let method_not_allowed =
30
+
v ~status:`Method_not_allowed ~content_type:"text/plain"
31
+
"Method Not Allowed"
32
+
33
+
let internal_server_error msg =
34
+
v ~status:`Internal_server_error ~content_type:"application/json"
35
+
(Fmt.str {|{"error":"%s"}|} msg)
36
+
37
+
let redirect url =
38
+
v ~status:`Found ~content_type:"text/plain"
39
+
~headers:[ ("Location", url) ]
40
+
""
41
+
end
42
+
43
+
type params = (string * string) list
44
+
type route = string * (params -> Response.t)
45
+
46
+
(* ── HTTP helpers ──────────────────────────────────────────────────── *)
47
+
48
+
let read_line reader =
49
+
let line = Eio.Buf_read.line reader in
50
+
let n = String.length line in
51
+
if n > 0 && line.[n - 1] = '\r' then String.sub line 0 (n - 1) else line
52
+
53
+
let skip_headers reader =
54
+
try
55
+
while true do
56
+
if String.length (read_line reader) = 0 then raise_notrace Exit
57
+
done
58
+
with Exit -> ()
59
+
60
+
let status_line (s : Status.t) =
61
+
Fmt.str "%d %s" (Status.to_int s) (Status.reason_phrase s)
62
+
63
+
let send_response flow (r : Response.t) =
64
+
let extra =
65
+
List.map (fun (k, v) -> Fmt.str "%s: %s\r\n" k v) r.headers
66
+
|> String.concat ""
67
+
in
68
+
let h =
69
+
Fmt.str
70
+
"HTTP/1.1 %s\r\n\
71
+
Content-Type: %s\r\n\
72
+
Content-Length: %d\r\n\
73
+
Access-Control-Allow-Origin: *\r\n\
74
+
%sConnection: close\r\n\
75
+
\r\n"
76
+
(status_line r.status) r.content_type (String.length r.body) extra
77
+
in
78
+
Eio.Flow.copy_string (h ^ r.body) flow
79
+
80
+
let send_cors flow =
81
+
Eio.Flow.copy_string
82
+
"HTTP/1.1 204 No Content\r\n\
83
+
Access-Control-Allow-Origin: *\r\n\
84
+
Access-Control-Allow-Methods: GET, POST, OPTIONS\r\n\
85
+
Access-Control-Allow-Headers: Content-Type, Authorization\r\n\
86
+
Access-Control-Max-Age: 86400\r\n\
87
+
Connection: close\r\n\
88
+
\r\n"
89
+
flow
90
+
91
+
(* ── URL parsing ──────────────────────────────────────────────────── *)
92
+
93
+
let parse_url url =
94
+
match String.index_opt url '?' with
95
+
| None -> (url, [])
96
+
| Some i ->
97
+
let path = String.sub url 0 i in
98
+
let qs = String.sub url (i + 1) (String.length url - i - 1) in
99
+
let params =
100
+
String.split_on_char '&' qs
101
+
|> List.filter_map (fun pair ->
102
+
match String.index_opt pair '=' with
103
+
| None -> if pair = "" then None else Some (pair, "")
104
+
| Some j ->
105
+
Some
106
+
( String.sub pair 0 j,
107
+
String.sub pair (j + 1) (String.length pair - j - 1) ))
108
+
in
109
+
(path, params)
110
+
111
+
(* ── Static file serving ──────────────────────────────────────────── *)
112
+
113
+
let normalize_path path =
114
+
let parts = String.split_on_char '/' path in
115
+
let rec resolve acc = function
116
+
| [] -> List.rev acc
117
+
| "" :: rest | "." :: rest -> resolve acc rest
118
+
| ".." :: rest -> (
119
+
match acc with [] -> resolve [] rest | _ :: t -> resolve t rest)
120
+
| part :: rest -> resolve (part :: acc) rest
121
+
in
122
+
String.concat "/" (resolve [] parts)
123
+
124
+
let generate_etag ~size = Fmt.str "W/\"%x\"" size
125
+
126
+
let try_serve_path ~root flow rel =
127
+
let full = Eio.Path.(root / rel) in
128
+
match Eio.Path.load full with
129
+
| body ->
130
+
let _, path_str = full in
131
+
let etag = generate_etag ~size:(String.length body) in
132
+
let ct = Magic_mime.lookup path_str in
133
+
let h =
134
+
Fmt.str
135
+
"HTTP/1.1 200 OK\r\n\
136
+
Content-Type: %s\r\n\
137
+
Content-Length: %d\r\n\
138
+
ETag: %s\r\n\
139
+
Cache-Control: public, max-age=3600\r\n\
140
+
Access-Control-Allow-Origin: *\r\n\
141
+
Connection: close\r\n\
142
+
\r\n"
143
+
ct (String.length body) etag
144
+
in
145
+
Eio.Flow.copy_string (h ^ body) flow;
146
+
true
147
+
| exception Eio.Io _ -> false
148
+
| exception Sys_error _ -> false
149
+
150
+
let serve_file ~root flow path =
151
+
let clean = normalize_path path in
152
+
if String.length clean > 1024 then send_response flow Response.not_found
153
+
else if try_serve_path ~root flow clean then ()
154
+
else if try_serve_path ~root flow (clean ^ "/index.html") then ()
155
+
else if clean = "" && try_serve_path ~root flow "index.html" then ()
156
+
else send_response flow Response.not_found
157
+
158
+
(* ── Request handling ─────────────────────────────────────────────── *)
159
+
160
+
let match_route routes path =
161
+
List.find_opt (fun (prefix, _) -> prefix = path) routes
162
+
163
+
let handle ~root ~routes flow reader =
164
+
let request_line = read_line reader in
165
+
skip_headers reader;
166
+
match String.split_on_char ' ' request_line with
167
+
| [] ->
168
+
Log.warn (fun m -> m "empty request line");
169
+
send_response flow (Response.bad_request "Bad Request")
170
+
| meth_str :: rest -> (
171
+
let meth = Method.of_string meth_str in
172
+
match (meth, rest) with
173
+
| `OPTIONS, _ ->
174
+
Log.debug (fun m -> m "OPTIONS (CORS preflight)");
175
+
send_cors flow
176
+
| (`GET | `HEAD), url :: _ ->
177
+
let path, params = parse_url url in
178
+
begin match match_route routes path with
179
+
| Some (_, handler) -> (
180
+
try
181
+
let r = handler params in
182
+
Log.info (fun m ->
183
+
m "%s %s %a" meth_str path Status.pp_hum r.Response.status);
184
+
send_response flow r
185
+
with exn ->
186
+
Log.err (fun m ->
187
+
m "%s %s 500 %s" meth_str path (Printexc.to_string exn));
188
+
send_response flow
189
+
(Response.internal_server_error (Printexc.to_string exn)))
190
+
| None ->
191
+
Log.info (fun m -> m "%s %s (static)" meth_str path);
192
+
serve_file ~root flow path
193
+
end
194
+
| _ ->
195
+
Log.warn (fun m -> m "%a 405" Method.pp meth);
196
+
send_response flow Response.method_not_allowed)
197
+
198
+
(* ── Server ───────────────────────────────────────────────────────── *)
199
+
200
+
let run ~net ~port ~root ~routes =
201
+
Log.info (fun m -> m "listening on http://0.0.0.0:%d" port);
202
+
Eio.Switch.run @@ fun sw ->
203
+
let addr = `Tcp (Eio.Net.Ipaddr.V4.any, port) in
204
+
let sock = Eio.Net.listen ~sw ~backlog:128 ~reuse_addr:true net addr in
205
+
while true do
206
+
Eio.Net.accept_fork ~sw sock
207
+
~on_error:(fun exn ->
208
+
Log.debug (fun m -> m "connection error: %s" (Printexc.to_string exn)))
209
+
(fun flow _addr ->
210
+
let reader = Eio.Buf_read.of_flow ~max_size:(1024 * 1024) flow in
211
+
handle ~root ~routes flow reader)
212
+
done
+102
lib/respond.mli
+102
lib/respond.mli
···
1
+
(** Eio HTTP server with static file serving and route handlers.
2
+
3
+
Reuses HTTP types ({!Status.t}, {!Method.t}) from [requests].
4
+
5
+
{2 Quick Start}
6
+
7
+
{[
8
+
Eio_main.run @@ fun env ->
9
+
let routes =
10
+
[
11
+
("/api/health", fun _params -> Respond.Response.json {|{"ok":true}|});
12
+
]
13
+
in
14
+
Respond.run ~net:(Eio.Stdenv.net env) ~port:8080
15
+
~root:(Eio.Stdenv.cwd env) ~routes
16
+
]} *)
17
+
18
+
(** {1 Types} *)
19
+
20
+
type params = (string * string) list
21
+
(** Query parameters as key-value pairs. *)
22
+
23
+
(** HTTP responses. *)
24
+
module Response : sig
25
+
type t = {
26
+
status : Status.t;
27
+
content_type : string;
28
+
body : string;
29
+
headers : (string * string) list;
30
+
}
31
+
32
+
val v :
33
+
?headers:(string * string) list ->
34
+
status:Status.t ->
35
+
content_type:string ->
36
+
string ->
37
+
t
38
+
(** General-purpose response constructor. *)
39
+
40
+
val json : string -> t
41
+
(** [json body] returns a 200 JSON response. *)
42
+
43
+
val text : string -> t
44
+
(** [text body] returns a 200 plain text response. *)
45
+
46
+
val html : string -> t
47
+
(** [html body] returns a 200 HTML response. *)
48
+
49
+
val raw : status:Status.t -> content_type:string -> string -> t
50
+
(** [raw ~status ~content_type body] returns a custom response. *)
51
+
52
+
val not_found : t
53
+
(** 404 Not Found. *)
54
+
55
+
val bad_request : string -> t
56
+
(** [bad_request msg] returns a 400 response. *)
57
+
58
+
val method_not_allowed : t
59
+
(** 405 Method Not Allowed. *)
60
+
61
+
val internal_server_error : string -> t
62
+
(** [internal_server_error msg] returns a 500 JSON error response. *)
63
+
64
+
val redirect : string -> t
65
+
(** [redirect url] returns a 302 redirect. *)
66
+
end
67
+
68
+
type route = string * (params -> Response.t)
69
+
(** A route is a path paired with a handler. *)
70
+
71
+
(** {1 URL and Path Utilities} *)
72
+
73
+
val parse_url : string -> string * params
74
+
(** [parse_url url] splits a request target into path and query parameters. Per
75
+
RFC 7230 §5.3. *)
76
+
77
+
val normalize_path : string -> string
78
+
(** [normalize_path path] resolves [.] and [..] segments per RFC 3986 §5.2.4.
79
+
Prevents directory traversal beyond root. *)
80
+
81
+
val status_line : Status.t -> string
82
+
(** [status_line status] returns ["CODE REASON"] for the HTTP status line. *)
83
+
84
+
val generate_etag : size:int -> string
85
+
(** [generate_etag ~size] returns a weak ETag based on content size. Per RFC
86
+
7232 §2.3. *)
87
+
88
+
val match_route : route list -> string -> route option
89
+
(** [match_route routes path] returns the first route matching [path] exactly,
90
+
or [None]. *)
91
+
92
+
(** {1 Running} *)
93
+
94
+
val run :
95
+
net:_ Eio.Net.t ->
96
+
port:int ->
97
+
root:Eio.Fs.dir_ty Eio.Path.t ->
98
+
routes:route list ->
99
+
unit
100
+
(** [run ~net ~port ~root ~routes] starts the server. API [routes] are matched
101
+
first; unmatched paths fall through to static file serving from [root].
102
+
Blocks until cancelled. *)
+23
respond.opam
+23
respond.opam
···
1
+
opam-version: "2.0"
2
+
synopsis: "Eio HTTP server with static file serving and route handlers"
3
+
description: """
4
+
Serves files from a document root with MIME detection, ETag
5
+
conditional requests, and directory index. Supports custom route
6
+
handlers for API endpoints. Reuses HTTP types from requests.
7
+
"""
8
+
maintainer: ["Thomas Gazagnaire <thomas@gazagnaire.org>"]
9
+
authors: ["Thomas Gazagnaire <thomas@gazagnaire.org>"]
10
+
license: "ISC"
11
+
depends: [
12
+
"ocaml" {>= "5.1"}
13
+
"dune" {>= "3.0"}
14
+
"requests"
15
+
"eio"
16
+
"logs"
17
+
"magic-mime"
18
+
"fmt"
19
+
]
20
+
build: [
21
+
["dune" "subst"] {dev}
22
+
["dune" "build" "-p" name "-j" jobs]
23
+
]
+730
test/test_respond.ml
+730
test/test_respond.ml
···
1
+
(** RFC 7230–7235 compliance tests for respond.
2
+
3
+
Test vectors derived from RFC 7230 (Message Syntax and Routing), RFC 7231
4
+
(Semantics and Content), RFC 7232 (Conditional Requests), RFC 7233 (Range
5
+
Requests), RFC 7234 (Caching), RFC 7235 (Auth). *)
6
+
7
+
(* ── Helpers ───────────────────────────────────────────────────────── *)
8
+
9
+
let check_string = Alcotest.(check string)
10
+
let check_bool = Alcotest.(check bool)
11
+
12
+
let check_status msg expected actual =
13
+
Alcotest.(check int) msg (Status.to_int expected) (Status.to_int actual)
14
+
15
+
let check_pair =
16
+
let pp_pair ppf (a, b) = Fmt.pf ppf "(%S, %S)" a b in
17
+
Alcotest.testable pp_pair ( = )
18
+
19
+
let check_params = Alcotest.(check (list check_pair))
20
+
21
+
(* ── URL parsing (RFC 7230 §5.3) ──────────────────────────────────── *)
22
+
23
+
let test_parse_url_simple () =
24
+
let path, params = Respond.parse_url "/index.html" in
25
+
check_string "path" "/index.html" path;
26
+
check_params "no params" [] params
27
+
28
+
let test_parse_url_with_query () =
29
+
let path, params = Respond.parse_url "/api/cdms?sort=pc&limit=10" in
30
+
check_string "path" "/api/cdms" path;
31
+
check_params "params" [ ("sort", "pc"); ("limit", "10") ] params
32
+
33
+
let test_parse_url_empty_query () =
34
+
let path, params = Respond.parse_url "/path?" in
35
+
check_string "path" "/path" path;
36
+
check_params "empty qs" [] params
37
+
38
+
let test_parse_url_root () =
39
+
let path, params = Respond.parse_url "/" in
40
+
check_string "path" "/" path;
41
+
check_params "no params" [] params
42
+
43
+
let test_parse_url_key_only () =
44
+
let path, params = Respond.parse_url "/search?q" in
45
+
check_string "path" "/search" path;
46
+
check_params "key only" [ ("q", "") ] params
47
+
48
+
let test_parse_url_multiple_eq () =
49
+
let path, params = Respond.parse_url "/f?a=1=2&b=3" in
50
+
check_string "path" "/f" path;
51
+
check_params "params" [ ("a", "1=2"); ("b", "3") ] params
52
+
53
+
let test_parse_url_empty_pairs () =
54
+
let _path, params = Respond.parse_url "/f?a=1&&b=2" in
55
+
check_params "skip empty" [ ("a", "1"); ("b", "2") ] params
56
+
57
+
let url_tests =
58
+
[
59
+
("simple path", `Quick, test_parse_url_simple);
60
+
("path with query", `Quick, test_parse_url_with_query);
61
+
("empty query string", `Quick, test_parse_url_empty_query);
62
+
("root path", `Quick, test_parse_url_root);
63
+
("query key no value", `Quick, test_parse_url_key_only);
64
+
("multiple equals", `Quick, test_parse_url_multiple_eq);
65
+
("empty pairs", `Quick, test_parse_url_empty_pairs);
66
+
]
67
+
68
+
(* ── Path normalization (RFC 3986 §5.2.4) ─────────────────────────── *)
69
+
70
+
let test_normalize_simple () =
71
+
check_string "simple" "foo/bar" (Respond.normalize_path "/foo/bar")
72
+
73
+
let test_normalize_trailing_slash () =
74
+
check_string "trailing" "foo/bar" (Respond.normalize_path "/foo/bar/")
75
+
76
+
let test_normalize_double_slash () =
77
+
check_string "double slash" "foo/bar" (Respond.normalize_path "//foo//bar")
78
+
79
+
let test_normalize_dot () =
80
+
check_string "dot" "foo/bar" (Respond.normalize_path "/foo/./bar")
81
+
82
+
let test_normalize_dotdot () =
83
+
check_string "dotdot" "bar" (Respond.normalize_path "/foo/../bar")
84
+
85
+
let test_normalize_dotdot_at_root () =
86
+
check_string "dotdot root" "bar" (Respond.normalize_path "/../bar")
87
+
88
+
let test_normalize_deep_traversal () =
89
+
check_string "deep traversal" "evil"
90
+
(Respond.normalize_path "/a/b/c/../../../../../../../evil")
91
+
92
+
let test_normalize_only_dots () =
93
+
check_string "only dots" "" (Respond.normalize_path "/../../..")
94
+
95
+
let test_normalize_empty () =
96
+
check_string "empty" "" (Respond.normalize_path "")
97
+
98
+
let test_normalize_complex () =
99
+
check_string "complex" "a/d" (Respond.normalize_path "/a/b/c/./../../d")
100
+
101
+
let normalize_tests =
102
+
[
103
+
("simple", `Quick, test_normalize_simple);
104
+
("trailing slash", `Quick, test_normalize_trailing_slash);
105
+
("double slash", `Quick, test_normalize_double_slash);
106
+
("dot segment", `Quick, test_normalize_dot);
107
+
("dotdot segment", `Quick, test_normalize_dotdot);
108
+
("dotdot at root", `Quick, test_normalize_dotdot_at_root);
109
+
("deep traversal", `Quick, test_normalize_deep_traversal);
110
+
("only dots", `Quick, test_normalize_only_dots);
111
+
("empty path", `Quick, test_normalize_empty);
112
+
("complex path", `Quick, test_normalize_complex);
113
+
]
114
+
115
+
(* ── Status line (RFC 7231 §6) ─────────────────────────────────────── *)
116
+
117
+
let test_status_200 () = check_string "200" "200 OK" (Respond.status_line `OK)
118
+
119
+
let test_status_206 () =
120
+
check_string "206" "206 Partial Content"
121
+
(Respond.status_line `Partial_content)
122
+
123
+
let test_status_302 () =
124
+
check_string "302" "302 Found" (Respond.status_line `Found)
125
+
126
+
let test_status_304 () =
127
+
check_string "304" "304 Not Modified" (Respond.status_line `Not_modified)
128
+
129
+
let test_status_400 () =
130
+
check_string "400" "400 Bad Request" (Respond.status_line `Bad_request)
131
+
132
+
let test_status_403 () =
133
+
check_string "403" "403 Forbidden" (Respond.status_line `Forbidden)
134
+
135
+
let test_status_404 () =
136
+
check_string "404" "404 Not Found" (Respond.status_line `Not_found)
137
+
138
+
let test_status_405 () =
139
+
check_string "405" "405 Method Not Allowed"
140
+
(Respond.status_line `Method_not_allowed)
141
+
142
+
let test_status_500 () =
143
+
check_string "500" "500 Internal Server Error"
144
+
(Respond.status_line `Internal_server_error)
145
+
146
+
let test_status_418 () =
147
+
check_string "418" "418 I'm a teapot" (Respond.status_line `I_m_a_teapot)
148
+
149
+
let status_tests =
150
+
[
151
+
("200 OK", `Quick, test_status_200);
152
+
("206 Partial Content", `Quick, test_status_206);
153
+
("302 Found", `Quick, test_status_302);
154
+
("304 Not Modified", `Quick, test_status_304);
155
+
("400 Bad Request", `Quick, test_status_400);
156
+
("403 Forbidden", `Quick, test_status_403);
157
+
("404 Not Found", `Quick, test_status_404);
158
+
("405 Method Not Allowed", `Quick, test_status_405);
159
+
("500 Internal Server Error", `Quick, test_status_500);
160
+
("418 I'm a teapot", `Quick, test_status_418);
161
+
]
162
+
163
+
(* ── Response module ───────────────────────────────────────────────── *)
164
+
165
+
let test_response_json () =
166
+
let r = Respond.Response.json {|{"ok":true}|} in
167
+
check_status "status" `OK r.status;
168
+
check_string "ct" "application/json" r.content_type;
169
+
check_string "body" {|{"ok":true}|} r.body
170
+
171
+
let test_response_text () =
172
+
let r = Respond.Response.text "hello" in
173
+
check_status "status" `OK r.status;
174
+
check_string "ct" "text/plain" r.content_type
175
+
176
+
let test_response_html () =
177
+
let r = Respond.Response.html "<h1>hi</h1>" in
178
+
check_status "status" `OK r.status;
179
+
check_string "ct" "text/html; charset=utf-8" r.content_type
180
+
181
+
let test_response_not_found () =
182
+
check_status "status" `Not_found Respond.Response.not_found.status
183
+
184
+
let test_response_bad_request () =
185
+
let r = Respond.Response.bad_request "bad" in
186
+
check_status "status" `Bad_request r.status
187
+
188
+
let test_response_method_not_allowed () =
189
+
check_status "status" `Method_not_allowed
190
+
Respond.Response.method_not_allowed.status
191
+
192
+
let test_response_redirect () =
193
+
let r = Respond.Response.redirect "https://ssa.space/" in
194
+
check_status "status" `Found r.status;
195
+
check_bool "has location" true
196
+
(List.exists (fun (k, _) -> k = "Location") r.headers)
197
+
198
+
let test_response_raw () =
199
+
let r =
200
+
Respond.Response.raw ~status:`Created ~content_type:"text/xml" "<x/>"
201
+
in
202
+
check_status "status" `Created r.status;
203
+
check_string "ct" "text/xml" r.content_type;
204
+
check_string "body" "<x/>" r.body
205
+
206
+
let test_response_v () =
207
+
let r =
208
+
Respond.Response.v ~status:`No_content ~content_type:"text/plain"
209
+
~headers:[ ("X-Custom", "yes") ]
210
+
""
211
+
in
212
+
check_status "status" `No_content r.status;
213
+
check_bool "custom header" true
214
+
(List.exists (fun (k, _) -> k = "X-Custom") r.headers)
215
+
216
+
let response_tests =
217
+
[
218
+
("json", `Quick, test_response_json);
219
+
("text", `Quick, test_response_text);
220
+
("html", `Quick, test_response_html);
221
+
("not_found", `Quick, test_response_not_found);
222
+
("bad_request", `Quick, test_response_bad_request);
223
+
("method_not_allowed", `Quick, test_response_method_not_allowed);
224
+
("redirect", `Quick, test_response_redirect);
225
+
("raw", `Quick, test_response_raw);
226
+
("v with headers", `Quick, test_response_v);
227
+
]
228
+
229
+
(* ── Method (RFC 7231 §4) ─────────────────────────────────────────── *)
230
+
231
+
let test_method_of_string () =
232
+
Alcotest.(check bool) "GET" true (Method.of_string "GET" = `GET);
233
+
Alcotest.(check bool) "POST" true (Method.of_string "POST" = `POST);
234
+
Alcotest.(check bool) "get" true (Method.of_string "get" = `GET);
235
+
Alcotest.(check bool) "PATCH" true (Method.of_string "PATCH" = `PATCH)
236
+
237
+
let test_method_unknown () =
238
+
match Method.of_string "PROPFIND" with
239
+
| `Other s -> check_string "unknown" "PROPFIND" s
240
+
| _ -> Alcotest.fail "expected Other"
241
+
242
+
let test_method_safe () =
243
+
check_bool "GET safe" true (Method.is_safe `GET);
244
+
check_bool "HEAD safe" true (Method.is_safe `HEAD);
245
+
check_bool "POST not safe" false (Method.is_safe `POST);
246
+
check_bool "DELETE not safe" false (Method.is_safe `DELETE)
247
+
248
+
let test_method_idempotent () =
249
+
check_bool "GET idemp" true (Method.is_idempotent `GET);
250
+
check_bool "PUT idemp" true (Method.is_idempotent `PUT);
251
+
check_bool "POST not idemp" false (Method.is_idempotent `POST);
252
+
check_bool "PATCH not idemp" false (Method.is_idempotent `PATCH)
253
+
254
+
let method_tests =
255
+
[
256
+
("of_string", `Quick, test_method_of_string);
257
+
("unknown method", `Quick, test_method_unknown);
258
+
("safe methods (RFC 7231 §4.2.1)", `Quick, test_method_safe);
259
+
("idempotent (RFC 7231 §4.2.2)", `Quick, test_method_idempotent);
260
+
]
261
+
262
+
(* ── ETag generation (RFC 7232 §2.3) ──────────────────────────────── *)
263
+
264
+
let test_etag_format () =
265
+
let etag = Respond.generate_etag ~size:1024 in
266
+
check_bool "starts with W/" true
267
+
(String.length etag >= 3 && String.sub etag 0 3 = "W/\"");
268
+
check_bool "ends with quote" true (etag.[String.length etag - 1] = '"')
269
+
270
+
let test_etag_different_sizes () =
271
+
let e1 = Respond.generate_etag ~size:100 in
272
+
let e2 = Respond.generate_etag ~size:200 in
273
+
check_bool "different sizes different etags" true (e1 <> e2)
274
+
275
+
let test_etag_same_size () =
276
+
let e1 = Respond.generate_etag ~size:100 in
277
+
let e2 = Respond.generate_etag ~size:100 in
278
+
check_string "same size same etag" e1 e2
279
+
280
+
let etag_tests =
281
+
[
282
+
("weak format", `Quick, test_etag_format);
283
+
("different sizes", `Quick, test_etag_different_sizes);
284
+
("same size", `Quick, test_etag_same_size);
285
+
]
286
+
287
+
(* ── MIME type detection (RFC 7231 §3.1.1.5) ──────────────────────── *)
288
+
289
+
let test_mime_html () =
290
+
check_string "html" "text/html" (Magic_mime.lookup "index.html")
291
+
292
+
let test_mime_js () =
293
+
check_string "js" "application/javascript" (Magic_mime.lookup "main.bc.js")
294
+
295
+
let test_mime_css () =
296
+
check_string "css" "text/css" (Magic_mime.lookup "style.css")
297
+
298
+
let test_mime_json () =
299
+
check_string "json" "application/json" (Magic_mime.lookup "data.json")
300
+
301
+
let test_mime_jpg () =
302
+
check_string "jpg" "image/jpeg" (Magic_mime.lookup "earth.jpg")
303
+
304
+
let test_mime_png () =
305
+
check_string "png" "image/png" (Magic_mime.lookup "icon.png")
306
+
307
+
let test_mime_svg () =
308
+
check_string "svg" "image/svg+xml" (Magic_mime.lookup "logo.svg")
309
+
310
+
let test_mime_csv () =
311
+
check_string "csv" "text/csv" (Magic_mime.lookup "data.csv")
312
+
313
+
let test_mime_woff2 () =
314
+
check_string "woff2" "font/woff2" (Magic_mime.lookup "font.woff2")
315
+
316
+
let test_mime_unknown () =
317
+
check_string "unknown" "application/octet-stream"
318
+
(Magic_mime.lookup "file.xyz123")
319
+
320
+
let mime_tests =
321
+
[
322
+
("html", `Quick, test_mime_html);
323
+
("js", `Quick, test_mime_js);
324
+
("css", `Quick, test_mime_css);
325
+
("json", `Quick, test_mime_json);
326
+
("jpg", `Quick, test_mime_jpg);
327
+
("png", `Quick, test_mime_png);
328
+
("svg", `Quick, test_mime_svg);
329
+
("csv", `Quick, test_mime_csv);
330
+
("woff2", `Quick, test_mime_woff2);
331
+
("unknown extension", `Quick, test_mime_unknown);
332
+
]
333
+
334
+
(* ── Security: path traversal (OWASP) ─────────────────────────────── *)
335
+
336
+
let test_traversal_basic () =
337
+
check_string "basic .." "etc/passwd" (Respond.normalize_path "/../etc/passwd")
338
+
339
+
let test_traversal_encoded () =
340
+
check_string "dotdot mid" "etc/passwd"
341
+
(Respond.normalize_path "/foo/../../etc/passwd")
342
+
343
+
let test_traversal_deep () =
344
+
check_string "deep" "etc/shadow"
345
+
(Respond.normalize_path "/a/b/c/d/../../../../../../../../etc/shadow")
346
+
347
+
let test_traversal_null () =
348
+
let p = Respond.normalize_path "/foo/bar" in
349
+
check_bool "clean path has no null" false (String.contains p '\x00')
350
+
351
+
let test_traversal_mixed () =
352
+
check_string "mixed" "a/b" (Respond.normalize_path "/a/./b/c/../")
353
+
354
+
let security_tests =
355
+
[
356
+
("basic traversal", `Quick, test_traversal_basic);
357
+
("mid-path traversal", `Quick, test_traversal_encoded);
358
+
("deep traversal", `Quick, test_traversal_deep);
359
+
("null byte", `Quick, test_traversal_null);
360
+
("mixed dot segments", `Quick, test_traversal_mixed);
361
+
]
362
+
363
+
(* ── Route matching ────────────────────────────────────────────────── *)
364
+
365
+
let test_route_exact_match () =
366
+
let routes : Respond.route list =
367
+
[
368
+
("/api/health", fun _ -> Respond.Response.json {|{"ok":true}|});
369
+
("/api/cdms", fun _ -> Respond.Response.json "[]");
370
+
]
371
+
in
372
+
check_bool "found" true (Respond.match_route routes "/api/health" <> None);
373
+
check_bool "found 2" true (Respond.match_route routes "/api/cdms" <> None)
374
+
375
+
let test_route_no_match () =
376
+
let routes : Respond.route list =
377
+
[ ("/api/health", fun _ -> Respond.Response.json "ok") ]
378
+
in
379
+
check_bool "not found" true (Respond.match_route routes "/api/unknown" = None)
380
+
381
+
let test_route_no_prefix_match () =
382
+
let routes : Respond.route list =
383
+
[ ("/api", fun _ -> Respond.Response.json "ok") ]
384
+
in
385
+
check_bool "no prefix" true (Respond.match_route routes "/api/health" = None)
386
+
387
+
let route_tests =
388
+
[
389
+
("exact match", `Quick, test_route_exact_match);
390
+
("no match", `Quick, test_route_no_match);
391
+
("no prefix match", `Quick, test_route_no_prefix_match);
392
+
]
393
+
394
+
(* ── HTTP method semantics (RFC 7231 §4, RFC 9110) ─────────────────── *)
395
+
396
+
(* Adapted from httpzo test_simple_get, test_post_with_body,
397
+
test_unknown_method, test_http10, test_keep_alive *)
398
+
399
+
let test_method_all_standard () =
400
+
let methods =
401
+
[
402
+
("GET", `GET);
403
+
("HEAD", `HEAD);
404
+
("POST", `POST);
405
+
("PUT", `PUT);
406
+
("DELETE", `DELETE);
407
+
("CONNECT", `CONNECT);
408
+
("OPTIONS", `OPTIONS);
409
+
("TRACE", `TRACE);
410
+
("PATCH", `PATCH);
411
+
]
412
+
in
413
+
List.iter
414
+
(fun (s, expected) ->
415
+
let m = Method.of_string s in
416
+
check_bool (Fmt.str "%s roundtrips" s) true (Method.equal m expected);
417
+
check_string (Fmt.str "%s to_string" s) s (Method.to_string m))
418
+
methods
419
+
420
+
let test_method_case_insensitive () =
421
+
(* RFC 7230 §3.1.1: method is case-sensitive, but of_string normalizes *)
422
+
check_bool "get" true (Method.of_string "get" = `GET);
423
+
check_bool "Get" true (Method.of_string "Get" = `GET);
424
+
check_bool "post" true (Method.of_string "post" = `POST)
425
+
426
+
let test_method_unknown_roundtrip () =
427
+
(* httpzo: test_unknown_method — PURGE is not standard *)
428
+
let m = Method.of_string "PURGE" in
429
+
(match m with
430
+
| `Other s -> check_string "PURGE" "PURGE" s
431
+
| _ -> Alcotest.fail "expected Other for PURGE");
432
+
let m2 = Method.of_string "PROPFIND" in
433
+
match m2 with
434
+
| `Other s -> check_string "PROPFIND" "PROPFIND" s
435
+
| _ -> Alcotest.fail "expected Other for PROPFIND"
436
+
437
+
let test_method_body_semantics () =
438
+
(* RFC 9110 §9.3: body semantics per method *)
439
+
check_bool "POST requires body" true
440
+
(Method.request_body_semantics `POST = Method.Body_required);
441
+
check_bool "PUT requires body" true
442
+
(Method.request_body_semantics `PUT = Method.Body_required);
443
+
check_bool "HEAD forbids body" true
444
+
(Method.request_body_semantics `HEAD = Method.Body_forbidden);
445
+
check_bool "TRACE forbids body" true
446
+
(Method.request_body_semantics `TRACE = Method.Body_forbidden);
447
+
check_bool "GET body optional" true
448
+
(Method.request_body_semantics `GET = Method.Body_optional);
449
+
check_bool "DELETE body optional" true
450
+
(Method.request_body_semantics `DELETE = Method.Body_optional)
451
+
452
+
let test_method_cacheable () =
453
+
(* RFC 7231 §4.2.3 *)
454
+
check_bool "GET cacheable" true (Method.is_cacheable `GET);
455
+
check_bool "HEAD cacheable" true (Method.is_cacheable `HEAD);
456
+
check_bool "POST cacheable" true (Method.is_cacheable `POST);
457
+
check_bool "PUT not cacheable" false (Method.is_cacheable `PUT);
458
+
check_bool "DELETE not cacheable" false (Method.is_cacheable `DELETE)
459
+
460
+
let method_semantics_tests =
461
+
[
462
+
("all 9 standard methods", `Quick, test_method_all_standard);
463
+
("case insensitive", `Quick, test_method_case_insensitive);
464
+
("unknown roundtrip (PURGE/PROPFIND)", `Quick, test_method_unknown_roundtrip);
465
+
("body semantics (RFC 9110 §9.3)", `Quick, test_method_body_semantics);
466
+
("cacheable (RFC 7231 §4.2.3)", `Quick, test_method_cacheable);
467
+
]
468
+
469
+
(* ── Status code coverage (RFC 7231 §6, adapted from httpzo) ──────── *)
470
+
471
+
let test_status_informational () =
472
+
check_string "100" "100 Continue" (Respond.status_line `Continue);
473
+
check_string "101" "101 Switching Protocols"
474
+
(Respond.status_line `Switching_protocols)
475
+
476
+
let test_status_success () =
477
+
check_string "200" "200 OK" (Respond.status_line `OK);
478
+
check_string "201" "201 Created" (Respond.status_line `Created);
479
+
check_string "204" "204 No Content" (Respond.status_line `No_content);
480
+
check_string "206" "206 Partial Content"
481
+
(Respond.status_line `Partial_content)
482
+
483
+
let test_status_redirection () =
484
+
check_string "301" "301 Moved Permanently"
485
+
(Respond.status_line `Moved_permanently);
486
+
check_string "302" "302 Found" (Respond.status_line `Found);
487
+
check_string "304" "304 Not Modified" (Respond.status_line `Not_modified);
488
+
check_string "307" "307 Temporary Redirect"
489
+
(Respond.status_line `Temporary_redirect);
490
+
check_string "308" "308 Permanent Redirect"
491
+
(Respond.status_line `Permanent_redirect)
492
+
493
+
let test_status_client_error () =
494
+
check_string "400" "400 Bad Request" (Respond.status_line `Bad_request);
495
+
check_string "401" "401 Unauthorized" (Respond.status_line `Unauthorized);
496
+
check_string "403" "403 Forbidden" (Respond.status_line `Forbidden);
497
+
check_string "404" "404 Not Found" (Respond.status_line `Not_found);
498
+
check_string "405" "405 Method Not Allowed"
499
+
(Respond.status_line `Method_not_allowed);
500
+
check_string "409" "409 Conflict" (Respond.status_line `Conflict);
501
+
check_string "413" "413 Payload Too Large"
502
+
(Respond.status_line `Payload_too_large);
503
+
check_string "416" "416 Range Not Satisfiable"
504
+
(Respond.status_line `Range_not_satisfiable);
505
+
check_string "429" "429 Too Many Requests"
506
+
(Respond.status_line `Too_many_requests)
507
+
508
+
let test_status_server_error () =
509
+
check_string "500" "500 Internal Server Error"
510
+
(Respond.status_line `Internal_server_error);
511
+
check_string "502" "502 Bad Gateway" (Respond.status_line `Bad_gateway);
512
+
check_string "503" "503 Service Unavailable"
513
+
(Respond.status_line `Service_unavailable);
514
+
check_string "504" "504 Gateway Timeout"
515
+
(Respond.status_line `Gateway_timeout)
516
+
517
+
let test_status_custom_code () =
518
+
let s = Respond.status_line (`Code 599) in
519
+
check_bool "custom code starts with 599" true
520
+
(String.length s >= 3 && String.sub s 0 3 = "599")
521
+
522
+
let test_status_roundtrip () =
523
+
(* of_int -> to_int roundtrip for all standard codes *)
524
+
let codes =
525
+
[
526
+
100;
527
+
101;
528
+
200;
529
+
201;
530
+
204;
531
+
206;
532
+
301;
533
+
302;
534
+
304;
535
+
307;
536
+
308;
537
+
400;
538
+
401;
539
+
403;
540
+
404;
541
+
405;
542
+
409;
543
+
413;
544
+
416;
545
+
429;
546
+
500;
547
+
502;
548
+
503;
549
+
504;
550
+
]
551
+
in
552
+
List.iter
553
+
(fun code ->
554
+
let s = Status.of_int code in
555
+
let code' = Status.to_int s in
556
+
Alcotest.(check int) (Fmt.str "roundtrip %d" code) code code')
557
+
codes
558
+
559
+
let status_coverage_tests =
560
+
[
561
+
("1xx informational", `Quick, test_status_informational);
562
+
("2xx success", `Quick, test_status_success);
563
+
("3xx redirection", `Quick, test_status_redirection);
564
+
("4xx client error", `Quick, test_status_client_error);
565
+
("5xx server error", `Quick, test_status_server_error);
566
+
("custom code", `Quick, test_status_custom_code);
567
+
("of_int/to_int roundtrip", `Quick, test_status_roundtrip);
568
+
]
569
+
570
+
(* ── URL edge cases (RFC 7230 §5.3, RFC 3986) ─────────────────────── *)
571
+
572
+
let test_url_fragment_ignored () =
573
+
(* Fragments should not appear in request-target per RFC 7230 §5.1,
574
+
but if present, parse_url sees them as part of query *)
575
+
let path, _params = Respond.parse_url "/page#section" in
576
+
check_string "path with fragment" "/page#section" path
577
+
578
+
let test_url_encoded_chars () =
579
+
let path, params = Respond.parse_url "/search?q=hello%20world" in
580
+
check_string "path" "/search" path;
581
+
check_params "encoded space" [ ("q", "hello%20world") ] params
582
+
583
+
let test_url_empty_value () =
584
+
let _path, params = Respond.parse_url "/f?key=" in
585
+
check_params "empty value" [ ("key", "") ] params
586
+
587
+
let test_url_multiple_same_key () =
588
+
let _path, params = Respond.parse_url "/f?a=1&a=2&a=3" in
589
+
check_params "multi key" [ ("a", "1"); ("a", "2"); ("a", "3") ] params
590
+
591
+
let test_url_long_query () =
592
+
let qs = String.make 1000 'x' in
593
+
let url = "/f?" ^ qs in
594
+
let path, params = Respond.parse_url url in
595
+
check_string "path" "/f" path;
596
+
check_bool "has param" true (List.length params = 1)
597
+
598
+
let test_url_special_chars () =
599
+
let _path, params =
600
+
Respond.parse_url "/f?redirect=https://example.com/path&token=abc"
601
+
in
602
+
check_params "special chars"
603
+
[ ("redirect", "https://example.com/path"); ("token", "abc") ]
604
+
params
605
+
606
+
let url_edge_tests =
607
+
[
608
+
("fragment in path", `Quick, test_url_fragment_ignored);
609
+
("percent-encoded chars", `Quick, test_url_encoded_chars);
610
+
("empty value", `Quick, test_url_empty_value);
611
+
("multiple same key", `Quick, test_url_multiple_same_key);
612
+
("long query string", `Quick, test_url_long_query);
613
+
("special chars in value", `Quick, test_url_special_chars);
614
+
]
615
+
616
+
(* ── Security: header injection (RFC 7230 §3.5, httpzo bare_cr) ───── *)
617
+
618
+
(* Adapted from httpzo test_bare_cr, test_ambiguous_framing *)
619
+
620
+
let test_header_crlf_injection () =
621
+
(* Headers module validates against CRLF injection *)
622
+
let caught = ref false in
623
+
(try
624
+
ignore (Headers.add_string "X-Evil" "value\r\nInjected: yes" Headers.empty)
625
+
with Headers.Invalid_header _ -> caught := true);
626
+
check_bool "CRLF in value rejected" true !caught
627
+
628
+
let test_header_name_injection () =
629
+
let caught = ref false in
630
+
(try ignore (Headers.add_string "X-Evil\r\n" "value" Headers.empty)
631
+
with Headers.Invalid_header _ -> caught := true);
632
+
check_bool "CRLF in name rejected" true !caught
633
+
634
+
let test_header_case_insensitive () =
635
+
let h = Headers.of_list [ ("Content-Type", "text/html") ] in
636
+
check_bool "lowercase lookup" true
637
+
(Headers.find (Header_name.of_string "content-type") h <> None);
638
+
check_bool "uppercase lookup" true
639
+
(Headers.find (Header_name.of_string "CONTENT-TYPE") h <> None)
640
+
641
+
let test_header_multiple_values () =
642
+
let h = Headers.of_list [ ("Accept", "text/html") ] in
643
+
let h = Headers.add_string "Accept" "application/json" h in
644
+
let values = Headers.all (Header_name.of_string "accept") h in
645
+
Alcotest.(check int) "two values" 2 (List.length values)
646
+
647
+
let header_security_tests =
648
+
[
649
+
( "CRLF in value rejected (RFC 7230 §3.5)",
650
+
`Quick,
651
+
test_header_crlf_injection );
652
+
("CRLF in name rejected", `Quick, test_header_name_injection);
653
+
( "case-insensitive lookup (RFC 7230 §3.2)",
654
+
`Quick,
655
+
test_header_case_insensitive );
656
+
("multiple values", `Quick, test_header_multiple_values);
657
+
]
658
+
659
+
(* ── Response helpers ──────────────────────────────────────────────── *)
660
+
661
+
let test_response_internal_error () =
662
+
let r = Respond.Response.internal_server_error "db timeout" in
663
+
check_status "status" `Internal_server_error r.status;
664
+
check_string "ct" "application/json" r.content_type;
665
+
check_bool "body has error" true (String.length r.body > 0)
666
+
667
+
let test_response_bad_request_msg () =
668
+
let r = Respond.Response.bad_request "missing field" in
669
+
check_status "status" `Bad_request r.status;
670
+
check_string "body" "missing field" r.body
671
+
672
+
let test_response_v_custom_status () =
673
+
let r =
674
+
Respond.Response.v ~status:(`Code 204) ~content_type:"text/plain" ""
675
+
in
676
+
Alcotest.(check int) "status 204" 204 (Status.to_int r.status)
677
+
678
+
let response_extra_tests =
679
+
[
680
+
("internal_server_error", `Quick, test_response_internal_error);
681
+
("bad_request with message", `Quick, test_response_bad_request_msg);
682
+
("v with custom code", `Quick, test_response_v_custom_status);
683
+
]
684
+
685
+
(* ── Path normalization edge cases (RFC 3986 §5.4 examples) ──────── *)
686
+
687
+
(* RFC 3986 §5.4 reference resolution examples *)
688
+
689
+
let test_rfc3986_examples () =
690
+
(* §5.4 Normal Examples (adapted for path-only resolution) *)
691
+
check_string "a/b/c" "a/b/c" (Respond.normalize_path "/a/b/c");
692
+
check_string "a" "a" (Respond.normalize_path "/./a");
693
+
check_string "mid/6" "mid/6" (Respond.normalize_path "/mid/content=5/../6")
694
+
695
+
let test_normalize_consecutive_dotdot () =
696
+
check_string "consecutive" "" (Respond.normalize_path "/a/b/../../");
697
+
check_string "three levels" "" (Respond.normalize_path "/a/b/c/../../../")
698
+
699
+
let test_normalize_unicode_path () =
700
+
(* UTF-8 path segments should be preserved *)
701
+
check_string "unicode" "café/résumé" (Respond.normalize_path "/café/résumé")
702
+
703
+
let normalize_extra_tests =
704
+
[
705
+
("RFC 3986 §5.4 examples", `Quick, test_rfc3986_examples);
706
+
("consecutive dotdot", `Quick, test_normalize_consecutive_dotdot);
707
+
("unicode path segments", `Quick, test_normalize_unicode_path);
708
+
]
709
+
710
+
(* ── Runner ────────────────────────────────────────────────────────── *)
711
+
712
+
let () =
713
+
Alcotest.run "respond"
714
+
[
715
+
("url-parsing (RFC 7230 §5.3)", url_tests);
716
+
("url-edge-cases (RFC 3986)", url_edge_tests);
717
+
("path-normalization (RFC 3986 §5.2.4)", normalize_tests);
718
+
("path-normalization-extra (RFC 3986 §5.4)", normalize_extra_tests);
719
+
("status-line (RFC 7231 §6)", status_tests);
720
+
("status-coverage (RFC 7231 §6)", status_coverage_tests);
721
+
("response", response_tests);
722
+
("response-extra", response_extra_tests);
723
+
("method (RFC 7231 §4)", method_tests);
724
+
("method-semantics (RFC 9110)", method_semantics_tests);
725
+
("etag (RFC 7232 §2.3)", etag_tests);
726
+
("mime (RFC 7231 §3.1.1.5)", mime_tests);
727
+
("security (OWASP)", security_tests);
728
+
("header-security (RFC 7230 §3.2-3.5)", header_security_tests);
729
+
("routing", route_tests);
730
+
]