An OCaml webserver, but the allocating version (vs httpz which doesnt)
anil.recoil.org
1(* server.ml - Eio static file server using httpzo *)
2
3open Eio.Std
4
5(* Response buffer size - 64KB for headers *)
6let response_buffer_size = 65536
7
8type config = {
9 port : int;
10 root : Eio.Fs.dir_ty Eio.Path.t;
11 limits : Buf_read.limits;
12}
13
14let 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 *)
21type '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 *)
33let 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 *)
45let mime_type_of_path path = Magic_mime.lookup path
46
47(* Generate weak ETag from file stats: W/"mtime-size" *)
48let generate_etag ~mtime ~size =
49 Printf.sprintf "W/\"%x-%Lx\"" (int_of_float (mtime *. 1000.0)) size
50
51(* Get current time *)
52let now () = Unix.gettimeofday ()
53
54(* Write common response headers *)
55let 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 "httpzo/0.1" in
58 Res.write_connection buf ~off ~keep_alive
59
60(* Write response headers for a full file response *)
61let 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 *)
73let 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 *)
86let 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 *)
95let 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 *)
103let 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 *)
108let 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 *)
119let 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 *)
136type 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 *)
144type request_headers =
145 { if_none_match : string option
146 ; range_count : int
147 }
148
149(* Get file metadata *)
150let 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 *)
160let 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 *)
180let 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 *)
257let 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 *)
267let 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 *)
284let 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 *)
300let 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 *)
314let 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 *)
325let 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 *)
385let 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 *)
390let 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 *)
408let 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 *)
416let run ~net ~sw config =
417 traceln "httpzo 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 ()