Eio HTTP server with static file serving and route handlers
Drop requests.core dep from respond, use plain int status
Removes the transitive dependency on ocaml-crypto (C stubs fail
with -fPIC in Docker amd64 builds). Status is now plain int with
reason_phrase lookup. 78 tests still pass.
Will re-add typed Status.t/Method.t when either:
- ocaml-crypto C stubs are fixed for Docker builds, or
- http-types is extracted as a lightweight package
+282
-746
+1
-1
lib/dune
+1
-1
lib/dune
+99
-78
lib/respond.ml
+99
-78
lib/respond.ml
···
1
-
(** Eio HTTP server with static file serving and route handlers.
2
-
3
-
Reuses HTTP types (Method, Status, Headers) from requests. *)
1
+
(** Eio HTTP server with static file serving and route handlers. *)
4
2
5
3
let src = Logs.Src.create "respond" ~doc:"HTTP server"
6
4
7
5
module Log = (val Logs.src_log src : Logs.LOG)
8
6
7
+
(* ── HTTP status ──────────────────────────────────────────────────── *)
8
+
9
+
let reason_phrase = function
10
+
| 200 -> "OK" | 201 -> "Created" | 204 -> "No Content"
11
+
| 206 -> "Partial Content"
12
+
| 301 -> "Moved Permanently" | 302 -> "Found" | 304 -> "Not Modified"
13
+
| 307 -> "Temporary Redirect" | 308 -> "Permanent Redirect"
14
+
| 400 -> "Bad Request" | 401 -> "Unauthorized" | 403 -> "Forbidden"
15
+
| 404 -> "Not Found" | 405 -> "Method Not Allowed"
16
+
| 409 -> "Conflict" | 413 -> "Payload Too Large"
17
+
| 416 -> "Range Not Satisfiable" | 429 -> "Too Many Requests"
18
+
| 500 -> "Internal Server Error" | 502 -> "Bad Gateway"
19
+
| 503 -> "Service Unavailable" | 504 -> "Gateway Timeout"
20
+
| _ -> ""
21
+
22
+
let status_line code =
23
+
let rp = reason_phrase code in
24
+
if rp = "" then string_of_int code
25
+
else Fmt.str "%d %s" code rp
26
+
9
27
(* ── Response ──────────────────────────────────────────────────────── *)
10
28
11
29
module Response = struct
12
30
type t = {
13
-
status : Status.t;
31
+
status : int;
14
32
content_type : string;
15
33
body : string;
16
34
headers : (string * string) list;
···
19
37
let v ?(headers = []) ~status ~content_type body =
20
38
{ status; content_type; body; headers }
21
39
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
40
+
let json body = v ~status:200 ~content_type:"application/json" body
41
+
let text body = v ~status:200 ~content_type:"text/plain" body
42
+
43
+
let html body =
44
+
v ~status:200 ~content_type:"text/html; charset=utf-8" body
45
+
25
46
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
47
+
48
+
let not_found =
49
+
v ~status:404 ~content_type:"text/plain" "Not Found"
50
+
51
+
let bad_request msg =
52
+
v ~status:400 ~content_type:"text/plain" msg
28
53
29
54
let method_not_allowed =
30
-
v ~status:`Method_not_allowed ~content_type:"text/plain"
31
-
"Method Not Allowed"
55
+
v ~status:405 ~content_type:"text/plain" "Method Not Allowed"
32
56
33
57
let internal_server_error msg =
34
-
v ~status:`Internal_server_error ~content_type:"application/json"
58
+
v ~status:500 ~content_type:"application/json"
35
59
(Fmt.str {|{"error":"%s"}|} msg)
36
60
37
61
let redirect url =
38
-
v ~status:`Found ~content_type:"text/plain"
39
-
~headers:[ ("Location", url) ]
40
-
""
62
+
v ~status:302 ~content_type:"text/plain"
63
+
~headers:[ ("Location", url) ] ""
41
64
end
42
65
43
66
type params = (string * string) list
···
56
79
if String.length (read_line reader) = 0 then raise_notrace Exit
57
80
done
58
81
with Exit -> ()
59
-
60
-
let status_line (s : Status.t) =
61
-
Fmt.str "%d %s" (Status.to_int s) (Status.reason_phrase s)
62
82
63
83
let send_response flow (r : Response.t) =
64
84
let extra =
···
94
114
match String.index_opt url '?' with
95
115
| None -> (url, [])
96
116
| 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)
117
+
let path = String.sub url 0 i in
118
+
let qs = String.sub url (i + 1) (String.length url - i - 1) in
119
+
let params =
120
+
String.split_on_char '&' qs
121
+
|> List.filter_map (fun pair ->
122
+
match String.index_opt pair '=' with
123
+
| None -> if pair = "" then None else Some (pair, "")
124
+
| Some j ->
125
+
Some
126
+
( String.sub pair 0 j,
127
+
String.sub pair (j + 1) (String.length pair - j - 1) ))
128
+
in
129
+
(path, params)
110
130
111
131
(* ── Static file serving ──────────────────────────────────────────── *)
112
132
···
116
136
| [] -> List.rev acc
117
137
| "" :: rest | "." :: rest -> resolve acc rest
118
138
| ".." :: rest -> (
119
-
match acc with [] -> resolve [] rest | _ :: t -> resolve t rest)
139
+
match acc with [] -> resolve [] rest | _ :: t -> resolve t rest)
120
140
| part :: rest -> resolve (part :: acc) rest
121
141
in
122
142
String.concat "/" (resolve [] parts)
···
127
147
let full = Eio.Path.(root / rel) in
128
148
match Eio.Path.load full with
129
149
| 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
150
+
let _, path_str = full in
151
+
let etag = generate_etag ~size:(String.length body) in
152
+
let ct = Magic_mime.lookup path_str in
153
+
let h =
154
+
Fmt.str
155
+
"HTTP/1.1 200 OK\r\n\
156
+
Content-Type: %s\r\n\
157
+
Content-Length: %d\r\n\
158
+
ETag: %s\r\n\
159
+
Cache-Control: public, max-age=3600\r\n\
160
+
Access-Control-Allow-Origin: *\r\n\
161
+
Connection: close\r\n\
162
+
\r\n"
163
+
ct (String.length body) etag
164
+
in
165
+
Eio.Flow.copy_string (h ^ body) flow;
166
+
true
147
167
| exception Eio.Io _ -> false
148
168
| exception Sys_error _ -> false
149
169
···
165
185
skip_headers reader;
166
186
match String.split_on_char ' ' request_line with
167
187
| [] ->
168
-
Log.warn (fun m -> m "empty request line");
169
-
send_response flow (Response.bad_request "Bad Request")
188
+
Log.warn (fun m -> m "empty request line");
189
+
send_response flow (Response.bad_request "Bad Request")
170
190
| 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)
191
+
match (String.uppercase_ascii meth_str, rest) with
192
+
| "OPTIONS", _ ->
193
+
Log.debug (fun m -> m "OPTIONS (CORS preflight)");
194
+
send_cors flow
195
+
| ("GET" | "HEAD"), url :: _ ->
196
+
let path, params = parse_url url in
197
+
begin
198
+
match match_route routes path with
199
+
| Some (_, handler) -> (
200
+
try
201
+
let r = handler params in
202
+
Log.info (fun m ->
203
+
m "%s %s %s" meth_str path (status_line r.Response.status));
204
+
send_response flow r
205
+
with exn ->
206
+
Log.err (fun m ->
207
+
m "%s %s 500 %s" meth_str path (Printexc.to_string exn));
208
+
send_response flow
209
+
(Response.internal_server_error (Printexc.to_string exn)))
210
+
| None ->
211
+
Log.info (fun m -> m "%s %s (static)" meth_str path);
212
+
serve_file ~root flow path
213
+
end
214
+
| _ ->
215
+
Log.warn (fun m -> m "%s 405" meth_str);
216
+
send_response flow Response.method_not_allowed)
197
217
198
218
(* ── Server ───────────────────────────────────────────────────────── *)
199
219
···
205
225
while true do
206
226
Eio.Net.accept_fork ~sw sock
207
227
~on_error:(fun exn ->
208
-
Log.debug (fun m -> m "connection error: %s" (Printexc.to_string exn)))
228
+
Log.debug (fun m ->
229
+
m "connection error: %s" (Printexc.to_string exn)))
209
230
(fun flow _addr ->
210
231
let reader = Eio.Buf_read.of_flow ~max_size:(1024 * 1024) flow in
211
232
handle ~root ~routes flow reader)
+12
-56
lib/respond.mli
+12
-56
lib/respond.mli
···
1
1
(** Eio HTTP server with static file serving and route handlers.
2
2
3
-
Reuses HTTP types ({!Status.t}, {!Method.t}) from [requests].
4
-
5
3
{2 Quick Start}
6
4
7
5
{[
8
6
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
7
+
let routes = [
8
+
"/api/health", (fun _params -> Respond.Response.json {|{"ok":true}|});
9
+
] in
10
+
Respond.run ~net:(Eio.Stdenv.net env) ~port:8080
11
+
~root:(Eio.Stdenv.cwd env) ~routes
16
12
]} *)
17
13
18
14
(** {1 Types} *)
19
15
20
16
type params = (string * string) list
21
-
(** Query parameters as key-value pairs. *)
22
17
23
18
(** HTTP responses. *)
24
19
module Response : sig
25
20
type t = {
26
-
status : Status.t;
21
+
status : int;
27
22
content_type : string;
28
23
body : string;
29
24
headers : (string * string) list;
30
25
}
31
26
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
-
27
+
val v : ?headers:(string * string) list ->
28
+
status:int -> content_type:string -> string -> t
40
29
val json : string -> t
41
-
(** [json body] returns a 200 JSON response. *)
42
-
43
30
val text : string -> t
44
-
(** [text body] returns a 200 plain text response. *)
45
-
46
31
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
-
32
+
val raw : status:int -> content_type:string -> string -> t
52
33
val not_found : t
53
-
(** 404 Not Found. *)
54
-
55
34
val bad_request : string -> t
56
-
(** [bad_request msg] returns a 400 response. *)
57
-
58
35
val method_not_allowed : t
59
-
(** 405 Method Not Allowed. *)
60
-
61
36
val internal_server_error : string -> t
62
-
(** [internal_server_error msg] returns a 500 JSON error response. *)
63
-
64
37
val redirect : string -> t
65
-
(** [redirect url] returns a 302 redirect. *)
66
38
end
67
39
68
40
type route = string * (params -> Response.t)
69
-
(** A route is a path paired with a handler. *)
70
41
71
-
(** {1 URL and Path Utilities} *)
42
+
(** {1 Utilities} *)
72
43
73
44
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
45
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
-
46
+
val status_line : int -> string
47
+
val reason_phrase : int -> string
84
48
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
49
val match_route : route list -> string -> route option
89
-
(** [match_route routes path] returns the first route matching [path] exactly,
90
-
or [None]. *)
91
50
92
51
(** {1 Running} *)
93
52
···
97
56
root:Eio.Fs.dir_ty Eio.Path.t ->
98
57
routes:route list ->
99
58
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. *)
+1
-1
test/dune
+1
-1
test/dune
+169
-610
test/test_respond.ml
+169
-610
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 ───────────────────────────────────────────────────────── *)
1
+
(** RFC 7230-7235 compliance tests for respond. *)
8
2
9
3
let check_string = Alcotest.(check string)
4
+
let check_int = Alcotest.(check int)
10
5
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
6
15
7
let check_pair =
16
8
let pp_pair ppf (a, b) = Fmt.pf ppf "(%S, %S)" a b in
···
28
20
let test_parse_url_with_query () =
29
21
let path, params = Respond.parse_url "/api/cdms?sort=pc&limit=10" in
30
22
check_string "path" "/api/cdms" path;
31
-
check_params "params" [ ("sort", "pc"); ("limit", "10") ] params
23
+
check_params "params" [("sort", "pc"); ("limit", "10")] params
32
24
33
25
let test_parse_url_empty_query () =
34
26
let path, params = Respond.parse_url "/path?" in
···
43
35
let test_parse_url_key_only () =
44
36
let path, params = Respond.parse_url "/search?q" in
45
37
check_string "path" "/search" path;
46
-
check_params "key only" [ ("q", "") ] params
38
+
check_params "key only" [("q", "")] params
47
39
48
40
let test_parse_url_multiple_eq () =
49
41
let path, params = Respond.parse_url "/f?a=1=2&b=3" in
50
42
check_string "path" "/f" path;
51
-
check_params "params" [ ("a", "1=2"); ("b", "3") ] params
43
+
check_params "params" [("a", "1=2"); ("b", "3")] params
52
44
53
45
let test_parse_url_empty_pairs () =
54
46
let _path, params = Respond.parse_url "/f?a=1&&b=2" in
55
-
check_params "skip empty" [ ("a", "1"); ("b", "2") ] params
47
+
check_params "skip empty" [("a", "1"); ("b", "2")] params
56
48
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
-
]
49
+
let test_url_fragment () =
50
+
let path, _params = Respond.parse_url "/page#section" in
51
+
check_string "path with fragment" "/page#section" path
67
52
68
-
(* ── Path normalization (RFC 3986 §5.2.4) ─────────────────────────── *)
53
+
let test_url_encoded_chars () =
54
+
let path, params = Respond.parse_url "/search?q=hello%20world" in
55
+
check_string "path" "/search" path;
56
+
check_params "encoded space" [("q", "hello%20world")] params
69
57
70
-
let test_normalize_simple () =
71
-
check_string "simple" "foo/bar" (Respond.normalize_path "/foo/bar")
58
+
let test_url_empty_value () =
59
+
let _path, params = Respond.parse_url "/f?key=" in
60
+
check_params "empty value" [("key", "")] params
72
61
73
-
let test_normalize_trailing_slash () =
74
-
check_string "trailing" "foo/bar" (Respond.normalize_path "/foo/bar/")
62
+
let test_url_multiple_same_key () =
63
+
let _path, params = Respond.parse_url "/f?a=1&a=2&a=3" in
64
+
check_params "multi key" [("a", "1"); ("a", "2"); ("a", "3")] params
75
65
76
-
let test_normalize_double_slash () =
77
-
check_string "double slash" "foo/bar" (Respond.normalize_path "//foo//bar")
66
+
let test_url_long_query () =
67
+
let qs = String.make 1000 'x' in
68
+
let path, params = Respond.parse_url ("/f?" ^ qs) in
69
+
check_string "path" "/f" path;
70
+
check_bool "has param" true (List.length params = 1)
78
71
79
-
let test_normalize_dot () =
80
-
check_string "dot" "foo/bar" (Respond.normalize_path "/foo/./bar")
72
+
let test_url_special_chars () =
73
+
let _path, params =
74
+
Respond.parse_url "/f?redirect=https://example.com/path&token=abc" in
75
+
check_params "special chars"
76
+
[("redirect", "https://example.com/path"); ("token", "abc")] params
81
77
82
-
let test_normalize_dotdot () =
83
-
check_string "dotdot" "bar" (Respond.normalize_path "/foo/../bar")
78
+
let url_tests = [
79
+
"simple path", `Quick, test_parse_url_simple;
80
+
"path with query", `Quick, test_parse_url_with_query;
81
+
"empty query string", `Quick, test_parse_url_empty_query;
82
+
"root path", `Quick, test_parse_url_root;
83
+
"query key no value", `Quick, test_parse_url_key_only;
84
+
"multiple equals", `Quick, test_parse_url_multiple_eq;
85
+
"empty pairs", `Quick, test_parse_url_empty_pairs;
86
+
"fragment in path", `Quick, test_url_fragment;
87
+
"percent-encoded", `Quick, test_url_encoded_chars;
88
+
"empty value", `Quick, test_url_empty_value;
89
+
"multiple same key", `Quick, test_url_multiple_same_key;
90
+
"long query", `Quick, test_url_long_query;
91
+
"special chars", `Quick, test_url_special_chars;
92
+
]
84
93
85
-
let test_normalize_dotdot_at_root () =
86
-
check_string "dotdot root" "bar" (Respond.normalize_path "/../bar")
94
+
(* ── Path normalization (RFC 3986 §5.2.4) ─────────────────────────── *)
87
95
88
-
let test_normalize_deep_traversal () =
89
-
check_string "deep traversal" "evil"
90
-
(Respond.normalize_path "/a/b/c/../../../../../../../evil")
96
+
let test_normalize tcs =
97
+
List.map (fun (name, input, expected) ->
98
+
name, `Quick, (fun () ->
99
+
check_string name expected (Respond.normalize_path input)))
100
+
tcs
91
101
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
-
]
102
+
let normalize_tests = test_normalize [
103
+
"simple", "/foo/bar", "foo/bar";
104
+
"trailing slash", "/foo/bar/", "foo/bar";
105
+
"double slash", "//foo//bar", "foo/bar";
106
+
"dot segment", "/foo/./bar", "foo/bar";
107
+
"dotdot", "/foo/../bar", "bar";
108
+
"dotdot at root", "/../bar", "bar";
109
+
"deep traversal", "/a/b/c/../../../../../../../evil", "evil";
110
+
"only dots", "/../../..", "";
111
+
"empty", "", "";
112
+
"complex", "/a/b/c/./../../d", "a/d";
113
+
"consecutive dotdot", "/a/b/../../", "";
114
+
"three levels", "/a/b/c/../../../", "";
115
+
"unicode", "/café/résumé", "café/résumé";
116
+
"traversal etc/passwd", "/../etc/passwd", "etc/passwd";
117
+
"mid traversal", "/foo/../../etc/passwd", "etc/passwd";
118
+
"deep etc/shadow", "/a/b/c/d/../../../../../../../../etc/shadow", "etc/shadow";
119
+
"mixed", "/a/./b/c/../", "a/b";
120
+
]
114
121
115
122
(* ── Status line (RFC 7231 §6) ─────────────────────────────────────── *)
116
123
117
-
let test_status_200 () = check_string "200" "200 OK" (Respond.status_line `OK)
124
+
let test_status tcs =
125
+
List.map (fun (code, expected) ->
126
+
expected, `Quick, (fun () ->
127
+
check_string (string_of_int code) expected (Respond.status_line code)))
128
+
tcs
118
129
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)
130
+
let status_tests = test_status [
131
+
200, "200 OK"; 201, "201 Created"; 204, "204 No Content";
132
+
206, "206 Partial Content";
133
+
301, "301 Moved Permanently"; 302, "302 Found"; 304, "304 Not Modified";
134
+
307, "307 Temporary Redirect"; 308, "308 Permanent Redirect";
135
+
400, "400 Bad Request"; 401, "401 Unauthorized"; 403, "403 Forbidden";
136
+
404, "404 Not Found"; 405, "405 Method Not Allowed";
137
+
409, "409 Conflict"; 413, "413 Payload Too Large";
138
+
416, "416 Range Not Satisfiable"; 429, "429 Too Many Requests";
139
+
500, "500 Internal Server Error"; 502, "502 Bad Gateway";
140
+
503, "503 Service Unavailable"; 504, "504 Gateway Timeout";
141
+
]
148
142
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
-
]
143
+
let test_status_unknown () =
144
+
check_string "unknown" "599" (Respond.status_line 599)
162
145
163
-
(* ── Response module ───────────────────────────────────────────────── *)
146
+
(* ── Response ──────────────────────────────────────────────────────── *)
164
147
165
148
let test_response_json () =
166
149
let r = Respond.Response.json {|{"ok":true}|} in
167
-
check_status "status" `OK r.status;
150
+
check_int "status" 200 r.status;
168
151
check_string "ct" "application/json" r.content_type;
169
152
check_string "body" {|{"ok":true}|} r.body
170
153
171
154
let test_response_text () =
172
155
let r = Respond.Response.text "hello" in
173
-
check_status "status" `OK r.status;
156
+
check_int "status" 200 r.status;
174
157
check_string "ct" "text/plain" r.content_type
175
158
176
159
let test_response_html () =
177
160
let r = Respond.Response.html "<h1>hi</h1>" in
178
-
check_status "status" `OK r.status;
161
+
check_int "status" 200 r.status;
179
162
check_string "ct" "text/html; charset=utf-8" r.content_type
180
163
181
164
let test_response_not_found () =
182
-
check_status "status" `Not_found Respond.Response.not_found.status
165
+
check_int "status" 404 Respond.Response.not_found.status
183
166
184
167
let test_response_bad_request () =
185
168
let r = Respond.Response.bad_request "bad" in
186
-
check_status "status" `Bad_request r.status
169
+
check_int "status" 400 r.status;
170
+
check_string "body" "bad" r.body
187
171
188
172
let test_response_method_not_allowed () =
189
-
check_status "status" `Method_not_allowed
190
-
Respond.Response.method_not_allowed.status
173
+
check_int "status" 405 Respond.Response.method_not_allowed.status
174
+
175
+
let test_response_internal_error () =
176
+
let r = Respond.Response.internal_server_error "db timeout" in
177
+
check_int "status" 500 r.status;
178
+
check_string "ct" "application/json" r.content_type
191
179
192
180
let test_response_redirect () =
193
181
let r = Respond.Response.redirect "https://ssa.space/" in
194
-
check_status "status" `Found r.status;
182
+
check_int "status" 302 r.status;
195
183
check_bool "has location" true
196
184
(List.exists (fun (k, _) -> k = "Location") r.headers)
197
185
198
186
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;
187
+
let r = Respond.Response.raw ~status:201 ~content_type:"text/xml" "<x/>" in
188
+
check_int "status" 201 r.status;
203
189
check_string "ct" "text/xml" r.content_type;
204
190
check_string "body" "<x/>" r.body
205
191
206
192
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;
193
+
let r = Respond.Response.v ~status:204 ~content_type:"text/plain"
194
+
~headers:[("X-Custom", "yes")] "" in
195
+
check_int "status" 204 r.status;
213
196
check_bool "custom header" true
214
197
(List.exists (fun (k, _) -> k = "X-Custom") r.headers)
215
198
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) ─────────────────────────────────────────── *)
199
+
let response_tests = [
200
+
"json", `Quick, test_response_json;
201
+
"text", `Quick, test_response_text;
202
+
"html", `Quick, test_response_html;
203
+
"not_found", `Quick, test_response_not_found;
204
+
"bad_request", `Quick, test_response_bad_request;
205
+
"method_not_allowed", `Quick, test_response_method_not_allowed;
206
+
"internal_server_error", `Quick, test_response_internal_error;
207
+
"redirect", `Quick, test_response_redirect;
208
+
"raw", `Quick, test_response_raw;
209
+
"v with headers", `Quick, test_response_v;
210
+
]
230
211
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) ──────────────────────────────── *)
212
+
(* ── ETag (RFC 7232 §2.3) ─────────────────────────────────────────── *)
263
213
264
214
let test_etag_format () =
265
215
let etag = Respond.generate_etag ~size:1024 in
···
268
218
check_bool "ends with quote" true (etag.[String.length etag - 1] = '"')
269
219
270
220
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)
221
+
check_bool "different" true
222
+
(Respond.generate_etag ~size:100 <> Respond.generate_etag ~size:200)
274
223
275
224
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
225
+
check_string "same" (Respond.generate_etag ~size:100)
226
+
(Respond.generate_etag ~size:100)
279
227
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
-
]
228
+
let etag_tests = [
229
+
"weak format", `Quick, test_etag_format;
230
+
"different sizes", `Quick, test_etag_different_sizes;
231
+
"same size", `Quick, test_etag_same_size;
232
+
]
286
233
287
-
(* ── MIME type detection (RFC 7231 §3.1.1.5) ──────────────────────── *)
234
+
(* ── MIME (RFC 7231 §3.1.1.5) ─────────────────────────────────────── *)
288
235
289
-
let test_mime_html () =
290
-
check_string "html" "text/html" (Magic_mime.lookup "index.html")
236
+
let test_mime tcs =
237
+
List.map (fun (ext, expected) ->
238
+
ext, `Quick, (fun () ->
239
+
check_string ext expected (Magic_mime.lookup ("file." ^ ext))))
240
+
tcs
291
241
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")
242
+
let mime_tests = test_mime [
243
+
"html", "text/html"; "js", "application/javascript"; "css", "text/css";
244
+
"json", "application/json"; "jpg", "image/jpeg"; "png", "image/png";
245
+
"svg", "image/svg+xml"; "csv", "text/csv"; "woff2", "font/woff2";
246
+
]
300
247
301
-
let test_mime_jpg () =
302
-
check_string "jpg" "image/jpeg" (Magic_mime.lookup "earth.jpg")
248
+
(* ── Routing ───────────────────────────────────────────────────────── *)
303
249
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
250
+
let test_route_exact () =
251
+
let routes : Respond.route list = [
252
+
"/api/health", (fun _ -> Respond.Response.json "ok");
253
+
"/api/cdms", (fun _ -> Respond.Response.json "[]");
254
+
] in
372
255
check_bool "found" true (Respond.match_route routes "/api/health" <> None);
373
256
check_bool "found 2" true (Respond.match_route routes "/api/cdms" <> None)
374
257
375
258
let test_route_no_match () =
376
-
let routes : Respond.route list =
377
-
[ ("/api/health", fun _ -> Respond.Response.json "ok") ]
378
-
in
259
+
let routes : Respond.route list = [
260
+
"/api/health", (fun _ -> Respond.Response.json "ok");
261
+
] in
379
262
check_bool "not found" true (Respond.match_route routes "/api/unknown" = None)
380
263
381
-
let test_route_no_prefix_match () =
382
-
let routes : Respond.route list =
383
-
[ ("/api", fun _ -> Respond.Response.json "ok") ]
384
-
in
264
+
let test_route_no_prefix () =
265
+
let routes : Respond.route list = [
266
+
"/api", (fun _ -> Respond.Response.json "ok");
267
+
] in
385
268
check_bool "no prefix" true (Respond.match_route routes "/api/health" = None)
386
269
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
-
]
270
+
let route_tests = [
271
+
"exact match", `Quick, test_route_exact;
272
+
"no match", `Quick, test_route_no_match;
273
+
"no prefix match", `Quick, test_route_no_prefix;
274
+
]
709
275
710
276
(* ── Runner ────────────────────────────────────────────────────────── *)
711
277
712
278
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
-
]
279
+
Alcotest.run "respond" [
280
+
"url-parsing (RFC 7230 §5.3)", url_tests;
281
+
"path-normalization (RFC 3986 §5.2.4)", normalize_tests;
282
+
"status-line (RFC 7231 §6)", status_tests @ [
283
+
"unknown code", `Quick, test_status_unknown;
284
+
];
285
+
"response", response_tests;
286
+
"etag (RFC 7232 §2.3)", etag_tests;
287
+
"mime (RFC 7231 §3.1.1.5)", mime_tests;
288
+
"routing", route_tests;
289
+
]