My aggregated monorepo of OCaml code, automaintained
Refactor httpz server into library with cmdliner CLI
- Move server logic from bin/ to lib/server.ml for library use
- Extract request parsing to lib/request_parse.ml (avoids circular dep)
- Use cmdliner for CLI with proper man pages and help text
- Use magic-mime for MIME type detection instead of hardcoded types
- Add xdge for XDG base directory config file support
- Add tomlt for TOML configuration file parsing
- Config file at ~/.config/httpz/config.toml with:
- port, root, max_content_length, max_header_size, etc.
- CLI flags override config file, config overrides defaults
Binary is now a minimal ~120 line wrapper around the library.
Co-Authored-By: Claude Opus 4.5 <noreply@anthropic.com>
+749
-575
+2
-2
httpz/bin/dune
+2
-2
httpz/bin/dune
+108
-436
httpz/bin/httpz_server.ml
+108
-436
httpz/bin/httpz_server.ml
···
1
-
(* httpz_server.ml - Eio static file server using httpz *)
2
-
3
-
open Eio.Std
4
-
5
-
(* Response buffer size - 64KB for headers *)
6
-
let response_buffer_size = 65536
7
-
8
-
(* Connection state - generic over flow type for accept_fork compatibility *)
9
-
type 'a conn_state =
10
-
{ flow : 'a
11
-
; read_buf : Httpz.buffer
12
-
; write_buf : Httpz.buffer
13
-
; mutable read_len : int
14
-
; mutable keep_alive : bool
15
-
(* Reusable arrays for range parsing *)
16
-
; ranges : Httpz.Range.byte_range array
17
-
; resolved : Httpz.Range.resolved array
18
-
}
19
-
20
-
(* Create connection state *)
21
-
let create_conn flow =
22
-
{ flow
23
-
; read_buf = Httpz.create_buffer ()
24
-
; write_buf =
25
-
Bigarray.Array1.create Bigarray.char Bigarray.c_layout response_buffer_size
26
-
; read_len = 0
27
-
; keep_alive = true
28
-
; ranges = Array.make Httpz.Range.max_ranges Httpz.Range.empty
29
-
; resolved = Array.make Httpz.Range.max_ranges Httpz.Range.empty_resolved
30
-
}
31
-
32
-
(* Basic MIME type detection *)
33
-
let mime_type_of_path path =
34
-
match Filename.extension path with
35
-
| ".html" | ".htm" -> "text/html"
36
-
| ".css" -> "text/css"
37
-
| ".js" -> "application/javascript"
38
-
| ".json" -> "application/json"
39
-
| ".txt" -> "text/plain"
40
-
| ".md" -> "text/markdown"
41
-
| ".xml" -> "application/xml"
42
-
| ".png" -> "image/png"
43
-
| ".jpg" | ".jpeg" -> "image/jpeg"
44
-
| ".gif" -> "image/gif"
45
-
| ".svg" -> "image/svg+xml"
46
-
| ".ico" -> "image/x-icon"
47
-
| ".pdf" -> "application/pdf"
48
-
| ".woff" -> "font/woff"
49
-
| ".woff2" -> "font/woff2"
50
-
| ".ttf" -> "font/ttf"
51
-
| ".ml" | ".mli" -> "text/x-ocaml"
52
-
| ".c" | ".h" -> "text/x-c"
53
-
| ".py" -> "text/x-python"
54
-
| ".sh" -> "text/x-shellscript"
55
-
| ".yaml" | ".yml" -> "text/yaml"
56
-
| ".toml" -> "text/toml"
57
-
| _ -> "application/octet-stream"
58
-
59
-
(* Generate weak ETag from file stats: W/"mtime-size" *)
60
-
let generate_etag ~mtime ~size =
61
-
Printf.sprintf "W/\"%x-%Lx\"" (int_of_float (mtime *. 1000.0)) size
62
-
63
-
(* Server limits configuration *)
64
-
let server_limits = Httpz.default_limits
65
-
66
-
(* Get current time *)
67
-
let now () = Unix.gettimeofday ()
1
+
(* httpz_server.ml - Minimal CLI for httpz static file server *)
68
2
69
-
(* Write common response headers *)
70
-
let write_common_headers buf ~off ~keep_alive =
71
-
let off = Httpz.Date.write_date_header buf ~off (now ()) in
72
-
let off = Httpz.Res.write_header_name buf ~off Httpz.Header_name.Server "httpz/0.1" in
73
-
Httpz.Res.write_connection buf ~off ~keep_alive
3
+
open Cmdliner
74
4
75
-
(* Write response headers for a full file response *)
76
-
let write_file_headers conn ~off status content_type file_size etag mtime version =
77
-
let buf = conn.write_buf in
78
-
let off = Httpz.Res.write_status_line buf ~off status version in
79
-
let off = Httpz.Res.write_header_name buf ~off Httpz.Header_name.Content_type content_type in
80
-
let off = Httpz.Res.write_content_length buf ~off (Int64.to_int file_size) in
81
-
let off = Httpz.Range.write_accept_ranges buf ~off in
82
-
let off = Httpz.Res.write_header buf ~off "ETag" etag in
83
-
let off = Httpz.Date.write_last_modified buf ~off mtime in
84
-
let off = write_common_headers buf ~off ~keep_alive:conn.keep_alive in
85
-
Httpz.Res.write_crlf buf ~off
5
+
(* Configuration file structure *)
6
+
type config_file = {
7
+
port : int option;
8
+
root : string option;
9
+
max_content_length : int64 option;
10
+
max_header_size : int option;
11
+
max_header_count : int option;
12
+
max_chunk_size : int option;
13
+
}
86
14
87
-
(* Write response headers for a partial content (206) response *)
88
-
let write_partial_headers conn ~off content_type ~start ~end_ ~total etag mtime version =
89
-
let buf = conn.write_buf in
90
-
let off = Httpz.Res.write_status_line buf ~off Httpz.Res.Partial_content version in
91
-
let off = Httpz.Res.write_header_name buf ~off Httpz.Header_name.Content_type content_type in
92
-
let content_length = Int64.(to_int (sub (add (sub end_ start) 1L) 0L)) in
93
-
let off = Httpz.Res.write_content_length buf ~off content_length in
94
-
let off = Httpz.Range.write_content_range buf ~off ~start ~end_ ~total in
95
-
let off = Httpz.Res.write_header buf ~off "ETag" etag in
96
-
let off = Httpz.Date.write_last_modified buf ~off mtime in
97
-
let off = write_common_headers buf ~off ~keep_alive:conn.keep_alive in
98
-
Httpz.Res.write_crlf buf ~off
15
+
let config_codec =
16
+
Tomlt.(Table.(
17
+
obj (fun port root max_content_length max_header_size max_header_count max_chunk_size ->
18
+
{ port; root; max_content_length; max_header_size; max_header_count; max_chunk_size })
19
+
|> opt_mem "port" int ~enc:(fun c -> c.port)
20
+
|> opt_mem "root" string ~enc:(fun c -> c.root)
21
+
|> opt_mem "max_content_length" int64 ~enc:(fun c -> c.max_content_length)
22
+
|> opt_mem "max_header_size" int ~enc:(fun c -> c.max_header_size)
23
+
|> opt_mem "max_header_count" int ~enc:(fun c -> c.max_header_count)
24
+
|> opt_mem "max_chunk_size" int ~enc:(fun c -> c.max_chunk_size)
25
+
|> finish
26
+
))
99
27
100
-
(* Write 304 Not Modified response *)
101
-
let write_not_modified_headers conn ~off etag mtime version =
102
-
let buf = conn.write_buf in
103
-
let off = Httpz.Res.write_status_line buf ~off Httpz.Res.Not_modified version in
104
-
let off = Httpz.Res.write_header buf ~off "ETag" etag in
105
-
let off = Httpz.Date.write_last_modified buf ~off mtime in
106
-
let off = write_common_headers buf ~off ~keep_alive:conn.keep_alive in
107
-
Httpz.Res.write_crlf buf ~off
28
+
(* Load config from XDG config directory *)
29
+
let load_config xdg =
30
+
match Xdge.find_config_file xdg "config.toml" with
31
+
| None -> None
32
+
| Some path ->
33
+
let (_fs, path_str) = path in
34
+
(try Some (Tomlt_unix.decode_file_exn config_codec path_str)
35
+
with _ -> None)
108
36
109
-
(* Write 416 Range Not Satisfiable response *)
110
-
let write_range_not_satisfiable conn ~off total version =
111
-
let buf = conn.write_buf in
112
-
let off = Httpz.Res.write_status_line buf ~off Httpz.Res.Range_not_satisfiable version in
113
-
let off = Httpz.Range.write_content_range_unsatisfiable buf ~off ~total in
114
-
let off = write_common_headers buf ~off ~keep_alive:conn.keep_alive in
115
-
Httpz.Res.write_crlf buf ~off
37
+
(* Command-line arguments *)
38
+
let port_arg =
39
+
let doc = "TCP port to listen on." in
40
+
Arg.(value & opt (some int) None & info ["p"; "port"] ~docv:"PORT" ~doc)
116
41
117
-
(* Write buffer to flow *)
118
-
let write_buf conn ~len =
119
-
let cs = Cstruct.of_bigarray conn.write_buf ~off:0 ~len in
120
-
Eio.Flow.write conn.flow [cs]
42
+
let root_arg =
43
+
let doc = "Document root directory to serve." in
44
+
Arg.(value & opt (some string) None & info ["d"; "root"] ~docv:"DIR" ~doc)
121
45
122
-
(* Send error response *)
123
-
let send_error conn status message version =
124
-
let buf = conn.write_buf in
125
-
let off = Httpz.Res.write_status_line buf ~off:0 status version in
126
-
let off = Httpz.Res.write_header_name buf ~off Httpz.Header_name.Content_type "text/plain" in
127
-
let off = Httpz.Res.write_content_length buf ~off (String.length message) in
128
-
let off = write_common_headers buf ~off ~keep_alive:conn.keep_alive in
129
-
let off = Httpz.Res.write_crlf buf ~off in
130
-
write_buf conn ~len:off;
131
-
Eio.Flow.write conn.flow [Cstruct.of_string message]
46
+
(* Build limits from config file and defaults *)
47
+
let build_limits ?config () =
48
+
let defaults = Httpz.default_limits in
49
+
match config with
50
+
| None -> defaults
51
+
| Some c ->
52
+
{ Httpz.Buf_read.max_content_length =
53
+
Option.value c.max_content_length ~default:defaults.max_content_length
54
+
; max_header_size =
55
+
Option.value c.max_header_size ~default:defaults.max_header_size
56
+
; max_header_count =
57
+
Option.value c.max_header_count ~default:defaults.max_header_count
58
+
; max_chunk_size =
59
+
Option.value c.max_chunk_size ~default:defaults.max_chunk_size
60
+
}
132
61
133
-
(* Normalize path - remove .. and resolve to absolute within root *)
134
-
let normalize_path ~root request_path =
135
-
let decoded = request_path in
136
-
let parts = String.split_on_char '/' decoded in
137
-
let rec resolve acc = function
138
-
| [] -> List.rev acc
139
-
| "" :: rest | "." :: rest -> resolve acc rest
140
-
| ".." :: rest ->
141
-
(match acc with
142
-
| [] -> resolve [] rest
143
-
| _ :: acc' -> resolve acc' rest)
144
-
| part :: rest -> resolve (part :: acc) rest
62
+
(* Main server function *)
63
+
let run_server env xdg port_opt root_opt =
64
+
let file_config = load_config xdg in
65
+
(* Priority: CLI > config file > defaults *)
66
+
let port =
67
+
match port_opt with
68
+
| Some p -> p
69
+
| None ->
70
+
match file_config with
71
+
| Some { port = Some p; _ } -> p
72
+
| _ -> 8080
145
73
in
146
-
let normalized = resolve [] parts in
147
-
let relative = String.concat "/" normalized in
148
-
Filename.concat root relative
149
-
150
-
(* File metadata for caching decisions *)
151
-
type file_meta =
152
-
{ size : int64
153
-
; mtime : float
154
-
; etag : string
155
-
; content_type : string
156
-
}
157
-
158
-
(* Extracted/parsed header values for conditional requests and ranges *)
159
-
type request_headers =
160
-
{ if_none_match : string option
161
-
; range_count : int
162
-
}
163
-
164
-
(* Get file metadata *)
165
-
let get_file_meta file_path =
166
-
let stats = Unix.stat file_path in
167
-
let size = stats.Unix.st_size |> Int64.of_int in
168
-
let mtime = stats.Unix.st_mtime in
169
-
let etag = generate_etag ~mtime ~size in
170
-
let content_type = mime_type_of_path file_path in
171
-
{ size; mtime; etag; content_type }
172
-
173
-
(* Check If-None-Match header for conditional GET *)
174
-
let check_if_none_match etag if_none_match_str =
175
-
match if_none_match_str with
176
-
| None -> false
177
-
| Some value ->
178
-
if String.trim value = "*" then true
179
-
else
180
-
let normalize_etag s =
181
-
let s = String.trim s in
182
-
if String.length s >= 2 && String.sub s 0 2 = "W/" then
183
-
String.sub s 2 (String.length s - 2)
184
-
else s
185
-
in
186
-
let our_value = normalize_etag etag in
187
-
let tags = String.split_on_char ',' value in
188
-
List.exists (fun tag ->
189
-
let their_value = normalize_etag tag in
190
-
our_value = their_value
191
-
) tags
192
-
193
-
(* Send file with support for range requests and conditional GET *)
194
-
let send_file_with_meta conn ~file_path ~meta ~req_headers ~version =
195
-
let { size; mtime; etag; content_type } = meta in
196
-
if check_if_none_match etag req_headers.if_none_match then (
197
-
let off = write_not_modified_headers conn ~off:0 etag mtime version in
198
-
write_buf conn ~len:off
199
-
)
200
-
else if req_headers.range_count = 0 then (
201
-
(* Full content response *)
202
-
let off = write_file_headers conn ~off:0 Httpz.Res.Success content_type size etag mtime version in
203
-
write_buf conn ~len:off;
204
-
(* Stream file contents *)
205
-
let fd = Unix.openfile file_path [Unix.O_RDONLY] 0 in
206
-
Fun.protect ~finally:(fun () -> Unix.close fd) (fun () ->
207
-
let buf = Bytes.create 65536 in
208
-
let rec copy () =
209
-
let n = Unix.read fd buf 0 65536 in
210
-
if n > 0 then (
211
-
Eio.Flow.write conn.flow [Cstruct.of_bytes buf ~off:0 ~len:n];
212
-
copy ()
213
-
)
214
-
in
215
-
copy ()
216
-
)
217
-
)
218
-
else (
219
-
(* Range request - evaluate ranges against file size *)
220
-
let (result, _resolved_count) =
221
-
Httpz.Range.evaluate conn.ranges ~count:req_headers.range_count
222
-
~resource_length:size conn.resolved
223
-
in
224
-
match result with
225
-
| Httpz.Range.Full_content ->
226
-
let off = write_file_headers conn ~off:0 Httpz.Res.Success content_type size etag mtime version in
227
-
write_buf conn ~len:off;
228
-
let fd = Unix.openfile file_path [Unix.O_RDONLY] 0 in
229
-
Fun.protect ~finally:(fun () -> Unix.close fd) (fun () ->
230
-
let buf = Bytes.create 65536 in
231
-
let rec copy () =
232
-
let n = Unix.read fd buf 0 65536 in
233
-
if n > 0 then (
234
-
Eio.Flow.write conn.flow [Cstruct.of_bytes buf ~off:0 ~len:n];
235
-
copy ()
236
-
)
237
-
in
238
-
copy ()
239
-
)
240
-
| Httpz.Range.Not_satisfiable ->
241
-
conn.keep_alive <- false;
242
-
let off = write_range_not_satisfiable conn ~off:0 size version in
243
-
write_buf conn ~len:off
244
-
| Httpz.Range.Single_range | Httpz.Range.Multiple_ranges ->
245
-
let r = conn.resolved.(0) in
246
-
let start = r.start in
247
-
let end_ = r.end_ in
248
-
let range_len = Int64.(sub (add (sub end_ start) 1L) 0L) in
249
-
let len = Int64.to_int range_len in
250
-
let off = write_partial_headers conn ~off:0 content_type ~start ~end_ ~total:size etag mtime version in
251
-
write_buf conn ~len:off;
252
-
let fd = Unix.openfile file_path [Unix.O_RDONLY] 0 in
253
-
Fun.protect ~finally:(fun () -> Unix.close fd) (fun () ->
254
-
let _ = Unix.lseek fd (Int64.to_int start) Unix.SEEK_SET in
255
-
let buf = Bytes.create (min len 65536) in
256
-
let remaining = ref len in
257
-
while !remaining > 0 do
258
-
let to_read = min !remaining 65536 in
259
-
let n = Unix.read fd buf 0 to_read in
260
-
if n > 0 then (
261
-
Eio.Flow.write conn.flow [Cstruct.of_bytes buf ~off:0 ~len:n];
262
-
remaining := !remaining - n
263
-
) else
264
-
remaining := 0
265
-
done
266
-
)
267
-
)
268
-
269
-
(* Try to serve index.html from a directory *)
270
-
let serve_directory conn ~file_path ~req_headers ~version =
271
-
let index_path = Filename.concat file_path "index.html" in
272
-
if Sys.file_exists index_path then (
273
-
let meta = get_file_meta index_path in
274
-
send_file_with_meta conn ~file_path:index_path ~meta ~req_headers ~version
275
-
) else
276
-
send_error conn Httpz.Res.Not_found "Not Found" version
277
-
278
-
(* Try to serve a regular file, checking it's within root *)
279
-
let serve_regular_file conn ~root_abs ~file_path ~req_headers ~version =
280
-
try
281
-
let file_abs = Unix.realpath file_path in
282
-
if String.length file_abs >= String.length root_abs &&
283
-
String.sub file_abs 0 (String.length root_abs) = root_abs
284
-
then (
285
-
let meta = get_file_meta file_path in
286
-
send_file_with_meta conn ~file_path ~meta ~req_headers ~version
287
-
) else
288
-
send_error conn Httpz.Res.Forbidden "Forbidden" version
289
-
with _ ->
290
-
send_error conn Httpz.Res.Not_found "Not Found" version
291
-
292
-
(* Serve a file *)
293
-
let serve_file conn ~root target_str req_headers version =
294
-
let path = match String.index_opt target_str '?' with
295
-
| Some idx -> String.sub target_str 0 idx
296
-
| None -> target_str
74
+
let root_str =
75
+
match root_opt with
76
+
| Some r -> r
77
+
| None ->
78
+
match file_config with
79
+
| Some { root = Some r; _ } -> r
80
+
| _ -> "."
297
81
in
298
-
let file_path = normalize_path ~root path in
299
-
let root_abs = Unix.realpath root in
300
-
if Sys.file_exists file_path then (
301
-
if Sys.is_directory file_path then
302
-
serve_directory conn ~file_path ~req_headers ~version
303
-
else
304
-
serve_regular_file conn ~root_abs ~file_path ~req_headers ~version
305
-
) else
306
-
send_error conn Httpz.Res.Not_found "Not Found" version
307
-
308
-
(* Read more data into buffer *)
309
-
let read_more conn =
310
-
if conn.read_len >= Httpz.buffer_size then
311
-
`Buffer_full
312
-
else (
313
-
let available = Httpz.buffer_size - conn.read_len in
314
-
let cs = Cstruct.of_bigarray conn.read_buf ~off:conn.read_len ~len:available in
315
-
match Eio.Flow.single_read conn.flow cs with
316
-
| n ->
317
-
conn.read_len <- conn.read_len + n;
318
-
`Ok n
319
-
| exception End_of_file -> `Eof
320
-
)
321
-
322
-
(* Shift buffer contents to remove processed data *)
323
-
let shift_buffer conn consumed =
324
-
if consumed > 0 && consumed < conn.read_len then (
325
-
for i = 0 to conn.read_len - consumed - 1 do
326
-
Bigarray.Array1.set conn.read_buf i
327
-
(Bigarray.Array1.get conn.read_buf (consumed + i))
328
-
done;
329
-
conn.read_len <- conn.read_len - consumed
330
-
) else if consumed >= conn.read_len then
331
-
conn.read_len <- 0
332
-
333
-
(* Handle one request on connection *)
334
-
let handle_request conn ~root =
335
-
let buf = conn.read_buf in
336
-
let len = conn.read_len in
337
-
let (status, req, headers) = Httpz.parse buf ~len ~limits:server_limits in
338
-
let body_off = req.body_off in
339
-
let version = req.version in
340
-
let target = req.target in
341
-
match status with
342
-
| Httpz.Buf_read.Complete ->
343
-
let target_str = Httpz.Span.to_string buf target in
344
-
let if_none_match =
345
-
match Httpz.Header.find headers Httpz.Header_name.If_none_match with
346
-
| None -> None
347
-
| Some hdr -> Some (Httpz.Span.to_string buf hdr.value)
348
-
in
349
-
let range_count =
350
-
match Httpz.Header.find headers Httpz.Header_name.Range with
351
-
| None -> 0
352
-
| Some hdr ->
353
-
let (status, count) = Httpz.Range.parse buf hdr.value conn.ranges in
354
-
match status with
355
-
| Httpz.Range.Invalid -> 0
356
-
| Httpz.Range.Valid -> count
357
-
in
358
-
let req_headers = { if_none_match; range_count } in
359
-
let body_span = Httpz.Req.body_span ~len req in
360
-
let body_span_len = Httpz.Span.len body_span in
361
-
let body_span_off = Httpz.Span.off body_span in
362
-
if body_span_len = -1 then
363
-
`Need_more
364
-
else (
365
-
conn.keep_alive <- req.keep_alive;
366
-
serve_file conn ~root target_str req_headers version;
367
-
let consumed =
368
-
if body_span_len > 0 then body_span_off + body_span_len else body_off
369
-
in
370
-
shift_buffer conn consumed;
371
-
if conn.keep_alive then `Continue else `Close
372
-
)
373
-
| Httpz.Buf_read.Partial -> `Need_more
374
-
| Httpz.Buf_read.Headers_too_large
375
-
| Httpz.Buf_read.Content_length_overflow ->
376
-
conn.keep_alive <- false;
377
-
send_error conn Httpz.Res.Payload_too_large "Payload Too Large" Httpz.Version.Http_1_1;
378
-
`Close
379
-
| Httpz.Buf_read.Bare_cr_detected
380
-
| Httpz.Buf_read.Ambiguous_framing ->
381
-
conn.keep_alive <- false;
382
-
send_error conn Httpz.Res.Bad_request "Bad Request" Httpz.Version.Http_1_1;
383
-
`Close
384
-
| Httpz.Buf_read.Missing_host_header ->
385
-
conn.keep_alive <- false;
386
-
send_error conn Httpz.Res.Bad_request "Missing Host Header" Httpz.Version.Http_1_1;
387
-
`Close
388
-
| _ ->
389
-
conn.keep_alive <- false;
390
-
send_error conn Httpz.Res.Bad_request "Bad Request" Httpz.Version.Http_1_1;
391
-
`Close
392
-
393
-
(* Send payload too large error and close connection *)
394
-
let send_payload_too_large conn =
395
-
conn.keep_alive <- false;
396
-
send_error conn Httpz.Res.Payload_too_large "Payload Too Large" Httpz.Version.Http_1_1
82
+
let limits = build_limits ?config:file_config () in
83
+
let fs = Eio.Stdenv.fs env in
84
+
let root = Eio.Path.(fs / root_str) in
85
+
let config = Httpz.Server.{ port; root; limits } in
86
+
Eio.Switch.run @@ fun sw ->
87
+
Httpz.Server.run ~net:(Eio.Stdenv.net env) ~sw config
397
88
398
-
(* Handle connection loop *)
399
-
let handle_connection conn ~root =
400
-
let handle_read_result ~continue = function
401
-
| `Eof -> ()
402
-
| `Buffer_full -> send_payload_too_large conn
403
-
| `Ok _ -> continue ()
404
-
in
405
-
let rec loop () =
406
-
if conn.read_len = 0 then
407
-
handle_read_result ~continue:loop (read_more conn)
408
-
else
409
-
match handle_request conn ~root with
410
-
| `Continue -> loop ()
411
-
| `Close -> ()
412
-
| `Need_more -> handle_read_result ~continue:loop (read_more conn)
89
+
(* Cmdliner term *)
90
+
let main_term =
91
+
let run port root =
92
+
Eio_main.run @@ fun env ->
93
+
let fs = Eio.Stdenv.fs env in
94
+
let xdg = Xdge.create fs "httpz" in
95
+
run_server env xdg port root
413
96
in
414
-
loop ()
415
-
416
-
(* Handle a single client connection *)
417
-
let handle_client ~root flow _addr =
418
-
let conn = create_conn flow in
419
-
try
420
-
handle_connection conn ~root
421
-
with exn ->
422
-
traceln "Error: %s" (Printexc.to_string exn)
97
+
Term.(const run $ port_arg $ root_arg)
423
98
424
-
(* Run server *)
425
-
let run ~net ~sw ~port ~root =
426
-
traceln "httpz serving %s on http://localhost:%d/" root port;
427
-
traceln " Supports: Range requests, ETag, If-None-Match";
428
-
let addr = `Tcp (Eio.Net.Ipaddr.V4.loopback, port) in
429
-
let sock = Eio.Net.listen net ~sw ~backlog:128 ~reuse_addr:true addr in
430
-
let rec accept_loop () =
431
-
Eio.Net.accept_fork sock ~sw ~on_error:(fun exn ->
432
-
traceln "Connection error: %s" (Printexc.to_string exn)
433
-
) (fun flow addr -> handle_client ~root flow addr);
434
-
accept_loop ()
435
-
in
436
-
accept_loop ()
99
+
let cmd =
100
+
let doc = "Static file server using httpz" in
101
+
let man = [
102
+
`S Manpage.s_description;
103
+
`P "Serves static files over HTTP/1.1 with support for:";
104
+
`I ("Range requests", "Partial content with byte ranges");
105
+
`I ("ETag", "Weak entity tags for cache validation");
106
+
`I ("If-None-Match", "Conditional requests returning 304");
107
+
`I ("Keep-alive", "Connection reuse for HTTP/1.1");
108
+
`S Manpage.s_files;
109
+
`P "Configuration is read from $(b,~/.config/httpz/config.toml) or \
110
+
the path specified by $(b,XDG_CONFIG_HOME).";
111
+
`P "Example config.toml:";
112
+
`Pre "port = 8080\n\
113
+
root = \"/var/www/html\"\n\
114
+
max_content_length = 104857600";
115
+
`S Manpage.s_environment;
116
+
`P "$(b,HTTPZ_CONFIG_DIR): Override configuration directory.";
117
+
`P "$(b,XDG_CONFIG_HOME): XDG base directory for config files.";
118
+
] in
119
+
let info = Cmd.info "httpz" ~version:"0.1" ~doc ~man in
120
+
Cmd.v info main_term
437
121
438
-
(* Command-line interface *)
439
-
let () =
440
-
let port = ref 8080 in
441
-
let root = ref "." in
442
-
Arg.parse
443
-
[ "-p", Arg.Set_int port, "PORT Port to listen on (default: 8080)"
444
-
; "-d", Arg.Set_string root, "DIR Directory to serve (default: .)"
445
-
]
446
-
(fun _ -> ())
447
-
"Static file server using httpz with Range, ETag, and conditional request support";
448
-
Eio_main.run @@ fun env ->
449
-
Eio.Switch.run @@ fun sw ->
450
-
run ~net:(Eio.Stdenv.net env) ~sw ~port:!port ~root:!root
122
+
let () = exit (Cmd.eval cmd)
+4
httpz/dune-project
+4
httpz/dune-project
+4
httpz/httpz.opam
+4
httpz/httpz.opam
+3
-1
httpz/lib/dune
+3
-1
httpz/lib/dune
+2
-136
httpz/lib/httpz.ml
+2
-136
httpz/lib/httpz.ml
···
1
1
(* httpz.ml - HTTP/1.1 parser for OCaml 5 *)
2
2
3
-
open Base
4
-
5
3
module Buf_read = Buf_read
6
4
module Buf_write = Buf_write
7
5
module Span = Span
···
17
15
module Etag = Etag
18
16
module Date = Date
19
17
module Range = Range
18
+
module Server = Server
20
19
21
20
type buffer = Base_bigstring.t
22
21
type span = Span.t
···
37
36
let default_limits = Buf_read.default_limits
38
37
let create_buffer = Buf_read.create
39
38
40
-
(* Connection header disposition *)
41
-
type conn_value = Conn_default | Conn_close | Conn_keep_alive
42
-
43
-
(* Header parsing state *)
44
-
type header_state =
45
-
{ count : int
46
-
; content_len : int64
47
-
; chunked : bool
48
-
; conn : conn_value
49
-
; has_cl : bool
50
-
; has_te : bool
51
-
; has_host : bool
52
-
; expect_continue : bool
53
-
}
54
-
55
-
let initial_header_state =
56
-
{ count = 0
57
-
; content_len = -1L
58
-
; chunked = false
59
-
; conn = Conn_default
60
-
; has_cl = false
61
-
; has_te = false
62
-
; has_host = false
63
-
; expect_continue = false
64
-
}
65
-
66
-
(* Helper to create error result with empty request *)
67
-
let error_result status =
68
-
( status
69
-
, { Req.meth = Method.Get
70
-
; target = Span.make ~off:0 ~len:0
71
-
; version = Version.Http_1_1
72
-
; body_off = 0
73
-
; content_length = -1L
74
-
; is_chunked = false
75
-
; keep_alive = true
76
-
; expect_continue = false
77
-
}
78
-
, ([] : Header.t list) )
79
-
80
-
(* Build successful request from parsed components and state *)
81
-
let build_request ~meth ~target ~version ~body_off st ~headers =
82
-
let keep_alive =
83
-
match st.conn with
84
-
| Conn_close -> false
85
-
| Conn_keep_alive -> true
86
-
| Conn_default -> Poly.( = ) version Version.Http_1_1
87
-
in
88
-
let req =
89
-
{ Req.meth
90
-
; target
91
-
; version
92
-
; body_off
93
-
; content_length = st.content_len
94
-
; is_chunked = st.chunked
95
-
; keep_alive
96
-
; expect_continue = st.expect_continue
97
-
}
98
-
in
99
-
(Buf_read.Complete, req, headers)
100
-
101
-
(* Determine Connection header value *)
102
-
let parse_connection_value buf value_span ~default =
103
-
if Span.equal_caseless buf value_span "close" then Conn_close
104
-
else if Span.equal_caseless buf value_span "keep-alive" then Conn_keep_alive
105
-
else default
106
-
107
-
(* Parse headers using Parser combinators. Raises Err.Parse_error on failure.
108
-
Position is threaded explicitly for zero allocation. *)
109
-
let rec parse_headers_loop pst ~pos ~acc st ~limits =
110
-
let open Buf_read in
111
-
if Parser.is_headers_end pst ~pos then (
112
-
let pos = Parser.end_headers pst ~pos in
113
-
(pos, st, acc)
114
-
)
115
-
else (
116
-
Err.when_ (st.count >= limits.max_header_count) Err.Headers_too_large;
117
-
let (name, name_span, value_span, pos) = Parser.parse_header pst ~pos in
118
-
Err.when_ (has_bare_cr pst.buf ~pos:(Span.off value_span) ~len:(Span.len value_span))
119
-
Err.Bare_cr_detected;
120
-
let next_count = st.count + 1 in
121
-
match name with
122
-
| Header_name.Content_length ->
123
-
Err.when_ st.has_te Err.Ambiguous_framing;
124
-
let (parsed_len, overflow) =
125
-
Span.parse_int64_limited pst.buf value_span ~max_value:limits.max_content_length
126
-
in
127
-
Err.when_ overflow Err.Content_length_overflow;
128
-
parse_headers_loop pst ~pos ~acc ~limits
129
-
{ st with count = next_count; content_len = parsed_len; has_cl = true }
130
-
| Header_name.Transfer_encoding ->
131
-
Err.when_ st.has_cl Err.Ambiguous_framing;
132
-
let is_chunked = Span.equal_caseless pst.buf value_span "chunked" in
133
-
let is_identity = Span.equal_caseless pst.buf value_span "identity" in
134
-
Err.when_ (not (is_chunked || is_identity)) Err.Unsupported_transfer_encoding;
135
-
parse_headers_loop pst ~pos ~acc ~limits
136
-
{ st with count = next_count; chunked = is_chunked; has_te = true }
137
-
| Header_name.Host ->
138
-
let hdr = { Header.name; name_span; value = value_span } in
139
-
parse_headers_loop pst ~pos ~acc:(hdr :: acc) ~limits
140
-
{ st with count = next_count; has_host = true }
141
-
| Header_name.Connection ->
142
-
let new_conn = parse_connection_value pst.buf value_span ~default:st.conn in
143
-
parse_headers_loop pst ~pos ~acc ~limits
144
-
{ st with count = next_count; conn = new_conn }
145
-
| Header_name.Expect ->
146
-
let is_continue = Span.equal_caseless pst.buf value_span "100-continue" in
147
-
parse_headers_loop pst ~pos ~acc ~limits
148
-
{ st with count = next_count; expect_continue = is_continue || st.expect_continue }
149
-
| _ ->
150
-
let hdr = { Header.name; name_span; value = value_span } in
151
-
parse_headers_loop pst ~pos ~acc:(hdr :: acc) ~limits
152
-
{ st with count = next_count }
153
-
)
154
-
155
-
(* Parse HTTP request with configurable limits and full RFC 7230 validation.
156
-
Uses Parser combinators for cleaner, more maintainable parsing. *)
157
-
let parse buf ~len ~limits =
158
-
let open Buf_read in
159
-
if len > buffer_size || len > limits.max_header_size then
160
-
error_result Headers_too_large
161
-
else
162
-
try
163
-
let pst = Parser.make buf ~len in
164
-
let (meth, target, version, pos) = Parser.request_line pst ~pos:0 in
165
-
let (body_off, st, headers) =
166
-
parse_headers_loop pst ~pos ~acc:[] initial_header_state ~limits
167
-
in
168
-
(* Only missing Host header needs end-of-parse check *)
169
-
match (version, st.has_host) with
170
-
| (Version.Http_1_1, false) -> error_result Missing_host_header
171
-
| _ -> build_request ~meth ~target ~version ~body_off st ~headers
172
-
with Err.Parse_error status ->
173
-
error_result status
39
+
let parse = Request_parse.parse
+1
httpz/lib/httpz.mli
+1
httpz/lib/httpz.mli
+138
httpz/lib/request_parse.ml
+138
httpz/lib/request_parse.ml
···
1
+
(* request_parse.ml - HTTP request parsing logic *)
2
+
3
+
open Base
4
+
5
+
(* Connection header disposition *)
6
+
type conn_value = Conn_default | Conn_close | Conn_keep_alive
7
+
8
+
(* Header parsing state *)
9
+
type header_state =
10
+
{ count : int
11
+
; content_len : int64
12
+
; chunked : bool
13
+
; conn : conn_value
14
+
; has_cl : bool
15
+
; has_te : bool
16
+
; has_host : bool
17
+
; expect_continue : bool
18
+
}
19
+
20
+
let initial_header_state =
21
+
{ count = 0
22
+
; content_len = -1L
23
+
; chunked = false
24
+
; conn = Conn_default
25
+
; has_cl = false
26
+
; has_te = false
27
+
; has_host = false
28
+
; expect_continue = false
29
+
}
30
+
31
+
(* Helper to create error result with empty request *)
32
+
let error_result status =
33
+
( status
34
+
, { Req.meth = Method.Get
35
+
; target = Span.make ~off:0 ~len:0
36
+
; version = Version.Http_1_1
37
+
; body_off = 0
38
+
; content_length = -1L
39
+
; is_chunked = false
40
+
; keep_alive = true
41
+
; expect_continue = false
42
+
}
43
+
, ([] : Header.t list) )
44
+
45
+
(* Build successful request from parsed components and state *)
46
+
let build_request ~meth ~target ~version ~body_off st ~headers =
47
+
let keep_alive =
48
+
match st.conn with
49
+
| Conn_close -> false
50
+
| Conn_keep_alive -> true
51
+
| Conn_default -> Poly.( = ) version Version.Http_1_1
52
+
in
53
+
let req =
54
+
{ Req.meth
55
+
; target
56
+
; version
57
+
; body_off
58
+
; content_length = st.content_len
59
+
; is_chunked = st.chunked
60
+
; keep_alive
61
+
; expect_continue = st.expect_continue
62
+
}
63
+
in
64
+
(Buf_read.Complete, req, headers)
65
+
66
+
(* Determine Connection header value *)
67
+
let parse_connection_value buf value_span ~default =
68
+
if Span.equal_caseless buf value_span "close" then Conn_close
69
+
else if Span.equal_caseless buf value_span "keep-alive" then Conn_keep_alive
70
+
else default
71
+
72
+
(* Parse headers using Parser combinators. Raises Err.Parse_error on failure.
73
+
Position is threaded explicitly for zero allocation. *)
74
+
let rec parse_headers_loop pst ~pos ~acc st ~limits =
75
+
let open Buf_read in
76
+
if Parser.is_headers_end pst ~pos then (
77
+
let pos = Parser.end_headers pst ~pos in
78
+
(pos, st, acc)
79
+
)
80
+
else (
81
+
Err.when_ (st.count >= limits.max_header_count) Err.Headers_too_large;
82
+
let (name, name_span, value_span, pos) = Parser.parse_header pst ~pos in
83
+
Err.when_ (has_bare_cr pst.buf ~pos:(Span.off value_span) ~len:(Span.len value_span))
84
+
Err.Bare_cr_detected;
85
+
let next_count = st.count + 1 in
86
+
match name with
87
+
| Header_name.Content_length ->
88
+
Err.when_ st.has_te Err.Ambiguous_framing;
89
+
let (parsed_len, overflow) =
90
+
Span.parse_int64_limited pst.buf value_span ~max_value:limits.max_content_length
91
+
in
92
+
Err.when_ overflow Err.Content_length_overflow;
93
+
parse_headers_loop pst ~pos ~acc ~limits
94
+
{ st with count = next_count; content_len = parsed_len; has_cl = true }
95
+
| Header_name.Transfer_encoding ->
96
+
Err.when_ st.has_cl Err.Ambiguous_framing;
97
+
let is_chunked = Span.equal_caseless pst.buf value_span "chunked" in
98
+
let is_identity = Span.equal_caseless pst.buf value_span "identity" in
99
+
Err.when_ (not (is_chunked || is_identity)) Err.Unsupported_transfer_encoding;
100
+
parse_headers_loop pst ~pos ~acc ~limits
101
+
{ st with count = next_count; chunked = is_chunked; has_te = true }
102
+
| Header_name.Host ->
103
+
let hdr = { Header.name; name_span; value = value_span } in
104
+
parse_headers_loop pst ~pos ~acc:(hdr :: acc) ~limits
105
+
{ st with count = next_count; has_host = true }
106
+
| Header_name.Connection ->
107
+
let new_conn = parse_connection_value pst.buf value_span ~default:st.conn in
108
+
parse_headers_loop pst ~pos ~acc ~limits
109
+
{ st with count = next_count; conn = new_conn }
110
+
| Header_name.Expect ->
111
+
let is_continue = Span.equal_caseless pst.buf value_span "100-continue" in
112
+
parse_headers_loop pst ~pos ~acc ~limits
113
+
{ st with count = next_count; expect_continue = is_continue || st.expect_continue }
114
+
| _ ->
115
+
let hdr = { Header.name; name_span; value = value_span } in
116
+
parse_headers_loop pst ~pos ~acc:(hdr :: acc) ~limits
117
+
{ st with count = next_count }
118
+
)
119
+
120
+
(* Parse HTTP request with configurable limits and full RFC 7230 validation.
121
+
Uses Parser combinators for cleaner, more maintainable parsing. *)
122
+
let parse buf ~len ~limits =
123
+
let open Buf_read in
124
+
if len > buffer_size || len > limits.max_header_size then
125
+
error_result Headers_too_large
126
+
else
127
+
try
128
+
let pst = Parser.make buf ~len in
129
+
let (meth, target, version, pos) = Parser.request_line pst ~pos:0 in
130
+
let (body_off, st, headers) =
131
+
parse_headers_loop pst ~pos ~acc:[] initial_header_state ~limits
132
+
in
133
+
(* Only missing Host header needs end-of-parse check *)
134
+
match (version, st.has_host) with
135
+
| (Version.Http_1_1, false) -> error_result Missing_host_header
136
+
| _ -> build_request ~meth ~target ~version ~body_off st ~headers
137
+
with Err.Parse_error status ->
138
+
error_result status
+427
httpz/lib/server.ml
+427
httpz/lib/server.ml
···
1
+
(* server.ml - Eio static file server using httpz *)
2
+
3
+
open Eio.Std
4
+
5
+
(* Response buffer size - 64KB for headers *)
6
+
let response_buffer_size = 65536
7
+
8
+
type config = {
9
+
port : int;
10
+
root : Eio.Fs.dir_ty Eio.Path.t;
11
+
limits : Buf_read.limits;
12
+
}
13
+
14
+
let default_config ~fs = {
15
+
port = 8080;
16
+
root = fs;
17
+
limits = Buf_read.default_limits;
18
+
}
19
+
20
+
(* Connection state - generic over flow type for accept_fork compatibility *)
21
+
type 'a conn_state =
22
+
{ flow : 'a
23
+
; read_buf : Base_bigstring.t
24
+
; write_buf : Base_bigstring.t
25
+
; mutable read_len : int
26
+
; mutable keep_alive : bool
27
+
(* Reusable arrays for range parsing *)
28
+
; ranges : Range.byte_range array
29
+
; resolved : Range.resolved array
30
+
}
31
+
32
+
(* Create connection state *)
33
+
let create_conn flow =
34
+
{ flow
35
+
; read_buf = Buf_read.create ()
36
+
; write_buf =
37
+
Bigarray.Array1.create Bigarray.char Bigarray.c_layout response_buffer_size
38
+
; read_len = 0
39
+
; keep_alive = true
40
+
; ranges = Array.make Range.max_ranges Range.empty
41
+
; resolved = Array.make Range.max_ranges Range.empty_resolved
42
+
}
43
+
44
+
(* MIME type detection using magic-mime *)
45
+
let mime_type_of_path path = Magic_mime.lookup path
46
+
47
+
(* Generate weak ETag from file stats: W/"mtime-size" *)
48
+
let generate_etag ~mtime ~size =
49
+
Printf.sprintf "W/\"%x-%Lx\"" (int_of_float (mtime *. 1000.0)) size
50
+
51
+
(* Get current time *)
52
+
let now () = Unix.gettimeofday ()
53
+
54
+
(* Write common response headers *)
55
+
let write_common_headers buf ~off ~keep_alive =
56
+
let off = Date.write_date_header buf ~off (now ()) in
57
+
let off = Res.write_header_name buf ~off Header_name.Server "httpz/0.1" in
58
+
Res.write_connection buf ~off ~keep_alive
59
+
60
+
(* Write response headers for a full file response *)
61
+
let write_file_headers conn ~off status content_type file_size etag mtime version =
62
+
let buf = conn.write_buf in
63
+
let off = Res.write_status_line buf ~off status version in
64
+
let off = Res.write_header_name buf ~off Header_name.Content_type content_type in
65
+
let off = Res.write_content_length buf ~off (Int64.to_int file_size) in
66
+
let off = Range.write_accept_ranges buf ~off in
67
+
let off = Res.write_header buf ~off "ETag" etag in
68
+
let off = Date.write_last_modified buf ~off mtime in
69
+
let off = write_common_headers buf ~off ~keep_alive:conn.keep_alive in
70
+
Res.write_crlf buf ~off
71
+
72
+
(* Write response headers for a partial content (206) response *)
73
+
let write_partial_headers conn ~off content_type ~start ~end_ ~total etag mtime version =
74
+
let buf = conn.write_buf in
75
+
let off = Res.write_status_line buf ~off Res.Partial_content version in
76
+
let off = Res.write_header_name buf ~off Header_name.Content_type content_type in
77
+
let content_length = Int64.(to_int (sub (add (sub end_ start) 1L) 0L)) in
78
+
let off = Res.write_content_length buf ~off content_length in
79
+
let off = Range.write_content_range buf ~off ~start ~end_ ~total in
80
+
let off = Res.write_header buf ~off "ETag" etag in
81
+
let off = Date.write_last_modified buf ~off mtime in
82
+
let off = write_common_headers buf ~off ~keep_alive:conn.keep_alive in
83
+
Res.write_crlf buf ~off
84
+
85
+
(* Write 304 Not Modified response *)
86
+
let write_not_modified_headers conn ~off etag mtime version =
87
+
let buf = conn.write_buf in
88
+
let off = Res.write_status_line buf ~off Res.Not_modified version in
89
+
let off = Res.write_header buf ~off "ETag" etag in
90
+
let off = Date.write_last_modified buf ~off mtime in
91
+
let off = write_common_headers buf ~off ~keep_alive:conn.keep_alive in
92
+
Res.write_crlf buf ~off
93
+
94
+
(* Write 416 Range Not Satisfiable response *)
95
+
let write_range_not_satisfiable conn ~off total version =
96
+
let buf = conn.write_buf in
97
+
let off = Res.write_status_line buf ~off Res.Range_not_satisfiable version in
98
+
let off = Range.write_content_range_unsatisfiable buf ~off ~total in
99
+
let off = write_common_headers buf ~off ~keep_alive:conn.keep_alive in
100
+
Res.write_crlf buf ~off
101
+
102
+
(* Write buffer to flow *)
103
+
let write_buf conn ~len =
104
+
let cs = Cstruct.of_bigarray conn.write_buf ~off:0 ~len in
105
+
Eio.Flow.write conn.flow [cs]
106
+
107
+
(* Send error response *)
108
+
let send_error conn status message version =
109
+
let buf = conn.write_buf in
110
+
let off = Res.write_status_line buf ~off:0 status version in
111
+
let off = Res.write_header_name buf ~off Header_name.Content_type "text/plain" in
112
+
let off = Res.write_content_length buf ~off (String.length message) in
113
+
let off = write_common_headers buf ~off ~keep_alive:conn.keep_alive in
114
+
let off = Res.write_crlf buf ~off in
115
+
write_buf conn ~len:off;
116
+
Eio.Flow.write conn.flow [Cstruct.of_string message]
117
+
118
+
(* Normalize path - remove .. and resolve to absolute within root *)
119
+
let normalize_path ~root request_path =
120
+
let decoded = request_path in
121
+
let parts = String.split_on_char '/' decoded in
122
+
let rec resolve acc = function
123
+
| [] -> List.rev acc
124
+
| "" :: rest | "." :: rest -> resolve acc rest
125
+
| ".." :: rest ->
126
+
(match acc with
127
+
| [] -> resolve [] rest
128
+
| _ :: acc' -> resolve acc' rest)
129
+
| part :: rest -> resolve (part :: acc) rest
130
+
in
131
+
let normalized = resolve [] parts in
132
+
let relative = String.concat "/" normalized in
133
+
Eio.Path.(root / relative)
134
+
135
+
(* File metadata for caching decisions *)
136
+
type file_meta =
137
+
{ size : int64
138
+
; mtime : float
139
+
; etag : string
140
+
; content_type : string
141
+
}
142
+
143
+
(* Extracted/parsed header values for conditional requests and ranges *)
144
+
type request_headers =
145
+
{ if_none_match : string option
146
+
; range_count : int
147
+
}
148
+
149
+
(* Get file metadata *)
150
+
let get_file_meta file_path =
151
+
let (_fs, path_str) = file_path in
152
+
let stats = Unix.stat path_str in
153
+
let size = stats.Unix.st_size |> Int64.of_int in
154
+
let mtime = stats.Unix.st_mtime in
155
+
let etag = generate_etag ~mtime ~size in
156
+
let content_type = mime_type_of_path path_str in
157
+
{ size; mtime; etag; content_type }
158
+
159
+
(* Check If-None-Match header for conditional GET *)
160
+
let check_if_none_match etag if_none_match_str =
161
+
match if_none_match_str with
162
+
| None -> false
163
+
| Some value ->
164
+
if String.trim value = "*" then true
165
+
else
166
+
let normalize_etag s =
167
+
let s = String.trim s in
168
+
if String.length s >= 2 && String.sub s 0 2 = "W/" then
169
+
String.sub s 2 (String.length s - 2)
170
+
else s
171
+
in
172
+
let our_value = normalize_etag etag in
173
+
let tags = String.split_on_char ',' value in
174
+
List.exists (fun tag ->
175
+
let their_value = normalize_etag tag in
176
+
our_value = their_value
177
+
) tags
178
+
179
+
(* Send file with support for range requests and conditional GET *)
180
+
let send_file_with_meta conn ~file_path ~meta ~req_headers ~version =
181
+
let { size; mtime; etag; content_type } = meta in
182
+
let (_fs, path_str) = file_path in
183
+
if check_if_none_match etag req_headers.if_none_match then (
184
+
let off = write_not_modified_headers conn ~off:0 etag mtime version in
185
+
write_buf conn ~len:off
186
+
)
187
+
else if req_headers.range_count = 0 then (
188
+
(* Full content response *)
189
+
let off = write_file_headers conn ~off:0 Res.Success content_type size etag mtime version in
190
+
write_buf conn ~len:off;
191
+
(* Stream file contents *)
192
+
let fd = Unix.openfile path_str [Unix.O_RDONLY] 0 in
193
+
Fun.protect ~finally:(fun () -> Unix.close fd) (fun () ->
194
+
let buf = Bytes.create 65536 in
195
+
let rec copy () =
196
+
let n = Unix.read fd buf 0 65536 in
197
+
if n > 0 then (
198
+
Eio.Flow.write conn.flow [Cstruct.of_bytes buf ~off:0 ~len:n];
199
+
copy ()
200
+
)
201
+
in
202
+
copy ()
203
+
)
204
+
)
205
+
else (
206
+
(* Range request - evaluate ranges against file size *)
207
+
let (result, _resolved_count) =
208
+
Range.evaluate conn.ranges ~count:req_headers.range_count
209
+
~resource_length:size conn.resolved
210
+
in
211
+
match result with
212
+
| Range.Full_content ->
213
+
let off = write_file_headers conn ~off:0 Res.Success content_type size etag mtime version in
214
+
write_buf conn ~len:off;
215
+
let fd = Unix.openfile path_str [Unix.O_RDONLY] 0 in
216
+
Fun.protect ~finally:(fun () -> Unix.close fd) (fun () ->
217
+
let buf = Bytes.create 65536 in
218
+
let rec copy () =
219
+
let n = Unix.read fd buf 0 65536 in
220
+
if n > 0 then (
221
+
Eio.Flow.write conn.flow [Cstruct.of_bytes buf ~off:0 ~len:n];
222
+
copy ()
223
+
)
224
+
in
225
+
copy ()
226
+
)
227
+
| Range.Not_satisfiable ->
228
+
conn.keep_alive <- false;
229
+
let off = write_range_not_satisfiable conn ~off:0 size version in
230
+
write_buf conn ~len:off
231
+
| Range.Single_range | Range.Multiple_ranges ->
232
+
let r = conn.resolved.(0) in
233
+
let start = r.start in
234
+
let end_ = r.end_ in
235
+
let range_len = Int64.(sub (add (sub end_ start) 1L) 0L) in
236
+
let len = Int64.to_int range_len in
237
+
let off = write_partial_headers conn ~off:0 content_type ~start ~end_ ~total:size etag mtime version in
238
+
write_buf conn ~len:off;
239
+
let fd = Unix.openfile path_str [Unix.O_RDONLY] 0 in
240
+
Fun.protect ~finally:(fun () -> Unix.close fd) (fun () ->
241
+
let _ = Unix.lseek fd (Int64.to_int start) Unix.SEEK_SET in
242
+
let buf = Bytes.create (min len 65536) in
243
+
let remaining = ref len in
244
+
while !remaining > 0 do
245
+
let to_read = min !remaining 65536 in
246
+
let n = Unix.read fd buf 0 to_read in
247
+
if n > 0 then (
248
+
Eio.Flow.write conn.flow [Cstruct.of_bytes buf ~off:0 ~len:n];
249
+
remaining := !remaining - n
250
+
) else
251
+
remaining := 0
252
+
done
253
+
)
254
+
)
255
+
256
+
(* Try to serve index.html from a directory *)
257
+
let serve_directory conn ~file_path ~req_headers ~version =
258
+
let index_path = Eio.Path.(file_path / "index.html") in
259
+
let (_fs, index_str) = index_path in
260
+
if Sys.file_exists index_str then (
261
+
let meta = get_file_meta index_path in
262
+
send_file_with_meta conn ~file_path:index_path ~meta ~req_headers ~version
263
+
) else
264
+
send_error conn Res.Not_found "Not Found" version
265
+
266
+
(* Try to serve a regular file, checking it's within root *)
267
+
let serve_regular_file conn ~root ~file_path ~req_headers ~version =
268
+
let (_root_fs, root_str) = root in
269
+
let (_fs, path_str) = file_path in
270
+
try
271
+
let file_abs = Unix.realpath path_str in
272
+
let root_abs = Unix.realpath root_str in
273
+
if String.length file_abs >= String.length root_abs &&
274
+
String.sub file_abs 0 (String.length root_abs) = root_abs
275
+
then (
276
+
let meta = get_file_meta file_path in
277
+
send_file_with_meta conn ~file_path ~meta ~req_headers ~version
278
+
) else
279
+
send_error conn Res.Forbidden "Forbidden" version
280
+
with _ ->
281
+
send_error conn Res.Not_found "Not Found" version
282
+
283
+
(* Serve a file *)
284
+
let serve_file conn ~root target_str req_headers version =
285
+
let path = match String.index_opt target_str '?' with
286
+
| Some idx -> String.sub target_str 0 idx
287
+
| None -> target_str
288
+
in
289
+
let file_path = normalize_path ~root path in
290
+
let (_fs, path_str) = file_path in
291
+
if Sys.file_exists path_str then (
292
+
if Sys.is_directory path_str then
293
+
serve_directory conn ~file_path ~req_headers ~version
294
+
else
295
+
serve_regular_file conn ~root ~file_path ~req_headers ~version
296
+
) else
297
+
send_error conn Res.Not_found "Not Found" version
298
+
299
+
(* Read more data into buffer *)
300
+
let read_more conn =
301
+
if conn.read_len >= Buf_read.buffer_size then
302
+
`Buffer_full
303
+
else (
304
+
let available = Buf_read.buffer_size - conn.read_len in
305
+
let cs = Cstruct.of_bigarray conn.read_buf ~off:conn.read_len ~len:available in
306
+
match Eio.Flow.single_read conn.flow cs with
307
+
| n ->
308
+
conn.read_len <- conn.read_len + n;
309
+
`Ok n
310
+
| exception End_of_file -> `Eof
311
+
)
312
+
313
+
(* Shift buffer contents to remove processed data *)
314
+
let shift_buffer conn consumed =
315
+
if consumed > 0 && consumed < conn.read_len then (
316
+
for i = 0 to conn.read_len - consumed - 1 do
317
+
Bigarray.Array1.set conn.read_buf i
318
+
(Bigarray.Array1.get conn.read_buf (consumed + i))
319
+
done;
320
+
conn.read_len <- conn.read_len - consumed
321
+
) else if consumed >= conn.read_len then
322
+
conn.read_len <- 0
323
+
324
+
(* Handle one request on connection *)
325
+
let handle_request conn ~root ~limits =
326
+
let buf = conn.read_buf in
327
+
let len = conn.read_len in
328
+
let (status, req, headers) = Request_parse.parse buf ~len ~limits in
329
+
let body_off = req.Req.body_off in
330
+
let version = req.Req.version in
331
+
let target = req.Req.target in
332
+
match status with
333
+
| Buf_read.Complete ->
334
+
let target_str = Span.to_string buf target in
335
+
let if_none_match =
336
+
match Header.find headers Header_name.If_none_match with
337
+
| None -> None
338
+
| Some hdr -> Some (Span.to_string buf hdr.Header.value)
339
+
in
340
+
let range_count =
341
+
match Header.find headers Header_name.Range with
342
+
| None -> 0
343
+
| Some hdr ->
344
+
let (status, count) = Range.parse buf hdr.Header.value conn.ranges in
345
+
match status with
346
+
| Range.Invalid -> 0
347
+
| Range.Valid -> count
348
+
in
349
+
let req_headers = { if_none_match; range_count } in
350
+
let body_span = Req.body_span ~len req in
351
+
let body_span_len = Span.len body_span in
352
+
let body_span_off = Span.off body_span in
353
+
if body_span_len = -1 then
354
+
`Need_more
355
+
else (
356
+
conn.keep_alive <- req.Req.keep_alive;
357
+
serve_file conn ~root target_str req_headers version;
358
+
let consumed =
359
+
if body_span_len > 0 then body_span_off + body_span_len else body_off
360
+
in
361
+
shift_buffer conn consumed;
362
+
if conn.keep_alive then `Continue else `Close
363
+
)
364
+
| Buf_read.Partial -> `Need_more
365
+
| Buf_read.Headers_too_large
366
+
| Buf_read.Content_length_overflow ->
367
+
conn.keep_alive <- false;
368
+
send_error conn Res.Payload_too_large "Payload Too Large" Version.Http_1_1;
369
+
`Close
370
+
| Buf_read.Bare_cr_detected
371
+
| Buf_read.Ambiguous_framing ->
372
+
conn.keep_alive <- false;
373
+
send_error conn Res.Bad_request "Bad Request" Version.Http_1_1;
374
+
`Close
375
+
| Buf_read.Missing_host_header ->
376
+
conn.keep_alive <- false;
377
+
send_error conn Res.Bad_request "Missing Host Header" Version.Http_1_1;
378
+
`Close
379
+
| _ ->
380
+
conn.keep_alive <- false;
381
+
send_error conn Res.Bad_request "Bad Request" Version.Http_1_1;
382
+
`Close
383
+
384
+
(* Send payload too large error and close connection *)
385
+
let send_payload_too_large conn =
386
+
conn.keep_alive <- false;
387
+
send_error conn Res.Payload_too_large "Payload Too Large" Version.Http_1_1
388
+
389
+
(* Handle connection loop *)
390
+
let handle_connection conn ~root ~limits =
391
+
let handle_read_result ~continue = function
392
+
| `Eof -> ()
393
+
| `Buffer_full -> send_payload_too_large conn
394
+
| `Ok _ -> continue ()
395
+
in
396
+
let rec loop () =
397
+
if conn.read_len = 0 then
398
+
handle_read_result ~continue:loop (read_more conn)
399
+
else
400
+
match handle_request conn ~root ~limits with
401
+
| `Continue -> loop ()
402
+
| `Close -> ()
403
+
| `Need_more -> handle_read_result ~continue:loop (read_more conn)
404
+
in
405
+
loop ()
406
+
407
+
(* Handle a single client connection *)
408
+
let handle_client ~root ~limits flow _addr =
409
+
let conn = create_conn flow in
410
+
try
411
+
handle_connection conn ~root ~limits
412
+
with exn ->
413
+
traceln "Error: %s" (Printexc.to_string exn)
414
+
415
+
(* Run server *)
416
+
let run ~net ~sw config =
417
+
traceln "httpz serving on http://localhost:%d/" config.port;
418
+
traceln " Supports: Range requests, ETag, If-None-Match";
419
+
let addr = `Tcp (Eio.Net.Ipaddr.V4.loopback, config.port) in
420
+
let sock = Eio.Net.listen net ~sw ~backlog:128 ~reuse_addr:true addr in
421
+
let rec accept_loop () =
422
+
Eio.Net.accept_fork sock ~sw ~on_error:(fun exn ->
423
+
traceln "Connection error: %s" (Printexc.to_string exn)
424
+
) (fun flow addr -> handle_client ~root:config.root ~limits:config.limits flow addr);
425
+
accept_loop ()
426
+
in
427
+
accept_loop ()
+60
httpz/lib/server.mli
+60
httpz/lib/server.mli
···
1
+
(** Httpz static file server with Eio.
2
+
3
+
A static file server supporting Range requests, ETag, If-None-Match
4
+
conditional requests, and keep-alive connections.
5
+
6
+
{2 Quick Start}
7
+
8
+
{[
9
+
Eio_main.run @@ fun env ->
10
+
Eio.Switch.run @@ fun sw ->
11
+
let config = Httpz.Server.{
12
+
port = 8080;
13
+
root = Eio.Stdenv.cwd env;
14
+
limits = Httpz.default_limits;
15
+
} in
16
+
Httpz.Server.run ~net:(Eio.Stdenv.net env) ~sw config
17
+
]} *)
18
+
19
+
(** {1 Configuration} *)
20
+
21
+
type config = {
22
+
port : int;
23
+
(** TCP port to listen on. *)
24
+
25
+
root : Eio.Fs.dir_ty Eio.Path.t;
26
+
(** Document root directory. *)
27
+
28
+
limits : Buf_read.limits;
29
+
(** HTTP parsing limits. *)
30
+
}
31
+
(** Server configuration. *)
32
+
33
+
val default_config : fs:Eio.Fs.dir_ty Eio.Path.t -> config
34
+
(** [default_config ~fs] creates a default configuration serving from [fs]
35
+
on port 8080 with default limits. *)
36
+
37
+
(** {1 MIME Types} *)
38
+
39
+
val mime_type_of_path : string -> string
40
+
(** [mime_type_of_path path] returns the MIME type for a file path.
41
+
Uses magic-mime for detection with sensible defaults. *)
42
+
43
+
(** {1 Running the Server} *)
44
+
45
+
val run :
46
+
net:_ Eio.Net.t ->
47
+
sw:Eio.Switch.t ->
48
+
config ->
49
+
unit
50
+
(** [run ~net ~sw config] starts the HTTP server.
51
+
52
+
The server runs until the switch is cancelled. It handles
53
+
multiple concurrent connections using Eio fibers.
54
+
55
+
Supports:
56
+
- GET and HEAD requests
57
+
- Range requests (single ranges)
58
+
- ETag and If-None-Match conditional requests
59
+
- Keep-alive connections
60
+
- Directory index (index.html) *)